(define-syntax datatype
  (lambda (x r c)
    (define (fold-left f accu l)
      (if (null? l)
	  accu
	  (fold-left f (f accu (car l)) (cdr l))))
    (let ((clauses (cddr x))
	  (%begin (r 'begin))
	  (%define (r 'define))
	  (%or (r 'or))
	  (%define-record-type (r 'define-record-type))
	  (%define-record-discloser (r 'define-record-discloser))
	  (type-name (cadr x))
	  (any->symbol
	   (lambda args
	     (string->symbol
	      (apply string-append
		     (map (lambda (arg)
			    (cond
			     ((symbol? arg) (symbol->string arg))
			     ((string? arg) arg)
			     ((number? arg) (number->string arg))))
			  args))))))
      (let ((defs.preds
	      (fold-left 
		  (lambda (defs.preds ctor-decl)
		    (let* ((ctor-name (any->symbol type-name "." (car ctor-decl)))
			   (ctor-test (any->symbol ctor-name "?"))
			   (ctor-type (any->symbol ":" ctor-name)))
		      
		      (cons
		       (cons
			`(,%define-record-type
			  ,ctor-name ,ctor-type
			  (,ctor-name ,@(cdr ctor-decl))
			  ,ctor-test
			  ,@(map (lambda (selector)
				   (list selector
					 (any->symbol ctor-name "->" selector)
					 (any->symbol ctor-name "->" selector "!")))
				 (cdr ctor-decl)))
			(cons 
			 `(,%define-record-discloser
			   ,ctor-type
			   (lambda (p)
			     (list ',ctor-name
				   ,@(map (lambda (selector)
					    (list (any->symbol ctor-name "->" selector) 'p))
					  (cdr ctor-decl)))))
			 (car defs.preds)))
		       (cons ctor-test (cdr defs.preds)))))
		  '(() . ())
		  clauses)))
      `(,%begin
	(,%define (,(any->symbol type-name "?") x) ;;; TODO rename x
		  (,%or ,@(map (lambda (pred) `(,pred x)) (cdr defs.preds))))
	,@(car defs.preds))))))