(define-syntax dd (syntax-rules () ((dd . foo) (void))))

(define (lookup id se)
  (cond ((assq id se) => cdr)
	((get id '##core#macro-alias))
	(else #f)))

(define (macro-alias var se)
  (if (or (##sys#qualified-symbol? var)
	  (let* ((str (##sys#slot var 1))
		 (len (##sys#size str)))
	    (and (fx> len 0)
		 (char=? #\# (string-ref str 0)))))
      var
      (let* ((alias (gensym var))
	     (ua (or (lookup var se) var)))
	(put! alias '##core#macro-alias ua)
	(put! alias '##core#real-name var)
	(dd "aliasing " alias " (real: " var ") to " 
	    (if (pair? ua)
		'<macro>
		ua))
	alias) ) )

(define ((my-er-macro-transformer handler) form se dse)
  (let ((renv '()))			; keep rename-environment for this expansion
    (define (rename sym)
      (cond ((pair? sym)
	     (cons (rename (car sym)) (rename (cdr sym))))
	    ((vector? sym)
	     (list->vector (rename (vector->list sym))))
	    ((not (symbol? sym)) sym)
	    ((assq sym renv) => 
	     (lambda (a) 
	       (dd `(RENAME/RENV: ,sym --> ,(cdr a)))
	       (cdr a)))
	    ((lookup sym se) => 
	     (lambda (a)
	       (cond ((symbol? a)
		      (dd `(RENAME/LOOKUP: ,sym --> ,a))
		      a)
		     (else
		      (let ((a2 (macro-alias sym se)))
			(dd `(RENAME/LOOKUP/MACRO: ,sym --> ,a2))
			(set! renv (cons (cons sym a2) renv))
			a2)))))
	    (else
	     (let ((a (macro-alias sym se)))
	       (dd `(RENAME: ,sym --> ,a))
	       (set! renv (cons (cons sym a) renv))
	       a))))
    (define (compare s1 s2)
      (let ((result
	     (cond ((pair? s1)
		    (and (pair? s2)
			 (compare (car s1) (car s2))
			 (compare (cdr s1) (cdr s2))))
		   ((vector? s1)
		    (and (vector? s2)
			 (let ((len (vector-length s1)))
			   (and (fx= len (vector-length s2))
				(do ((i 0 (fx+ i 1))
				     (f #t (compare (vector-ref s1 i) (vector-ref s2 i))))
				    ((or (fx>= i len) (not f)) f))))))
		   ((and (symbol? s1) (symbol? s2))
		    (let ((ss1 (or (get s1 '##core#macro-alias)
				   (lookup2 1 s1 dse)
				   s1) )
			  (ss2 (or (get s2 '##core#macro-alias)
				   (lookup2 2 s2 dse)
				   s2) ) )
		      (cond ((symbol? ss1)
			     (cond ((symbol? ss2) 
				    (eq? (or (get ss1 '##core#primitive) ss1)
					 (or (get ss2 '##core#primitive) ss2)))
				   ((assq ss1 (##sys#macro-environment)) =>
				    (lambda (a) (eq? (cdr a) ss2)))
				   (else #f) ) )
			    ((symbol? ss2)
			     (cond ((assq ss2 (##sys#macro-environment)) =>
				    (lambda (a) (eq? ss1 (cdr a))))
				   (else #f)))
			    (else (eq? ss1 ss2)))))
		   (else (eq? s1 s2))) ) ) 
	(dd `(COMPARE: ,s1 ,s2 --> ,result)) 
	result))
    (define (lookup2 n sym dse)
      (let ((r (lookup sym dse)))
	(dd "  (lookup/DSE " (list n) ": " sym " --> " 
	    (if (and r (pair? r))
		'<macro>
		r)
	    ")")
	r))
    (handler form rename compare) ) )

(define-syntax my-cond
  (my-er-macro-transformer   ;; Change this to er-macro-transformer and it works
   (lambda (exp rename compare)
     (let ((clauses (cdr exp)))
       (if (null? clauses)
           `(,(rename 'quote) unspecified)
           (let* ((first (car clauses))
                  (rest (cdr clauses))
                  (test (car first)))
             (cond ((and (symbol? test)
                         (compare test (rename 'else)))
                    `(,(rename 'begin) ,@(cdr first)))
                   (else `(,(rename 'if)
                           ,test
                           (,(rename 'begin) ,@(cdr first))
                           (cond ,@rest))))))))))

;; Should print foo
(let ((blabla #f)) (my-cond (else (print "foo"))))

;; Should print nothing
(let ((else #f)) (my-cond (else (print "foo"))))

;; Should print foo
(let ((else #t)) (my-cond (else (print "foo"))))