diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss
index a3283d07..526d9184 100644
--- a/collects/typed-scheme/private/parse-type.ss
+++ b/collects/typed-scheme/private/parse-type.ss
@@ -28,10 +28,12 @@
 (define (stx-cadr stx) (stx-car (stx-cdr stx)))
 
 (define-syntax-class star
+  #:description "*"
   (pattern star:id
            #:when (eq? '* #'star.datum)))
 
 (define-syntax-class ddd
+  #:description "..."
   (pattern ddd:id
            #:when (eq? '... #'ddd.datum)))
 
@@ -140,7 +142,8 @@
   #:description "\na sequence of identifiers\n"
   (pattern (v:id ...)))
 
-(define-syntax-class all-type  
+(define-syntax-class all-type 
+  #:description "All type"
   #:transparent
   #:literals (t:All)
   (pattern (t:All :all-ddd-formals b)  
diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss
index f24f7258..0617aa0f 100644
--- a/collects/typed-scheme/private/type-utils.ss
+++ b/collects/typed-scheme/private/type-utils.ss
@@ -37,7 +37,7 @@
   (define (sb t) (substitute image name t))
   (if (hash-ref (free-vars* target) name #f)
       (type-case sb target
-		 ;[#:Union tys (Un (map sb tys))]
+		 [#:Union tys (Un (map sb tys))]
                  [#:F name* (if (eq? name* name) image target)]
                  [#:arr dom rng rest drest kws thn-eff els-eff
                         (begin
@@ -142,7 +142,7 @@
 ;; must be applied to a Mu
 (define (unfold t)
   (match t
-    [(Mu: name b) (substitute t name b #:Un make-Union)]
+    [(Mu: name b) (substitute t name b #:Un (lambda (tys) (make-Union (sort tys < #:key Type-seq))))]
     [_ (int-err "unfold: requires Mu type, got ~a" t)]))
 
 (define (instantiate-poly t types)
diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss
index d9eb6ff4..2430ee4a 100644
--- a/collects/typed-scheme/rep/interning.ss
+++ b/collects/typed-scheme/rep/interning.ss
@@ -1,25 +1,25 @@
 #lang scheme/base
 
-(require syntax/boundmap)
+(require syntax/boundmap (for-syntax scheme/base stxclass))
 
 (provide defintern hash-id)
 
 
-(define-syntax defintern
-  (syntax-rules ()
-    [(_ name+args make-name key) 
-     (defintern name+args (lambda () (make-hash #;'weak)) make-name key)]
-    [(_ (*name arg ...) make-ht make-name key-expr)
-     (define *name
-       (let ([table (make-ht)])
-         (lambda (arg ...)
-           #;(all-count!)
-           (let ([key key-expr])
-             (hash-ref table key
-                       (lambda ()
-                         (let ([new (make-name (count!) arg ...)])
-                           (hash-set! table key new)
-                           new)))))))]))
+(define-syntax (defintern stx)
+  (syntax-parse stx
+    [(_ name+args make-name key ([#:extra-arg e:expr]) ...*) 
+     #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)]
+    [(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*)
+     #'(define *name
+	 (let ([table (make-ht)])
+	   (lambda (arg ...)
+	     #;(all-count!)
+	     (let ([key key-expr])
+	       (hash-ref table key
+			 (lambda ()
+			   (let ([new (make-name (count!) e ... arg ...)])
+			     (hash-set! table key new)
+			     new)))))))]))
 
 (define (make-count!)
   
diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss
index 679b2e33..2d2ecc7d 100644
--- a/collects/typed-scheme/rep/rep-utils.ss
+++ b/collects/typed-scheme/rep/rep-utils.ss
@@ -8,10 +8,11 @@
          "interning.ss"
          mzlib/etc
          (for-syntax 
+          stxclass
           scheme/base
           syntax/struct
           syntax/stx
-	  (utils utils)))
+	  (rename-in (utils utils) [id mk-id])))
 
 (provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq Type-key)
 
@@ -43,123 +44,88 @@
 
 (define-syntaxes (dt de)
   (let ()
-    (define (parse-opts opts stx)
-      (let loop ([provide? #t] [intern? #f] [frees #t] [fold-rhs #f] [key '(#f)] [opts opts])
-        (cond 
-          [(null? opts) (values provide? intern? frees fold-rhs key)]
-          [(eq? '#:no-provide (syntax-e (stx-car opts)))
-           (loop #f intern? frees fold-rhs key (cdr opts))]
-          [(eq? '#:no-frees (syntax-e (stx-car opts)))
-           (loop #f intern? #f fold-rhs key (cdr opts))]
-          [(not (and (stx-pair? opts) (stx-pair? (stx-car opts))))
-           (raise-syntax-error #f "bad options" stx)]
-          [(eq? '#:intern (syntax-e (stx-car (car opts))))
-           (loop provide? (stx-car (stx-cdr (car opts))) frees fold-rhs key (cdr opts))]
-          [(eq? '#:frees (syntax-e (stx-car (car opts))))
-           (loop provide? intern? (stx-cdr (car opts)) fold-rhs key (cdr opts))]
-          [(eq? '#:fold-rhs (syntax-e (stx-car (car opts))))
-           (loop provide? intern? frees (stx-cdr (car opts)) key (cdr opts))]
-	  [(eq? '#:key (syntax-e (stx-car (car opts))))
-	   (loop provide? intern? frees fold-rhs (stx-cdr (car opts)) (cdr opts))]
-          [else (raise-syntax-error #f "bad options" stx)])))
+    (define-syntax-class no-provide-kw
+      (pattern #:no-provide))
+    (define-syntax-class idlist
+      (pattern (i:id ...)))
+    (define (combiner f flds)
+      (syntax-parse flds
+        [() #'empty-hash-table]
+        [(e) #`(#,f e)]
+        [(e ...) #`(combine-frees (list (#,f e) ...))]))
+    (define-syntax-class frees-pat
+      #:transparent
+      #:attributes (f1 f2)
+      (pattern (f1:expr f2:expr))
+      (pattern (#f)
+               #:with f1 #'empty-hash-table
+               #:with f2 #'empty-hash-table))
+    (define-syntax-class fold-pat
+      #:transparent
+      #:attributes (e)
+      (pattern #:base
+               #:with e fold-target)
+      (pattern ex:expr
+	       #:with e #'#'ex))
     (define (mk par ht-stx)        
       (lambda (stx)          
-        (syntax-case stx ()
-          [(dform nm flds . opts)
-           (let*-values ([(provide? intern? frees fold-rhs key-expr) (parse-opts (syntax->list #'opts) #'opts)]
-                         [(kw) (string->keyword (symbol->string (syntax-e #'nm)))])
-             (with-syntax* 
-                 ([ex (id #'nm #'nm ":")]
-                  [kw-stx kw]
-		  [(key-expr) key-expr]
-                  [parent par]
-                  [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds) #f #t #'nm)]
-                  [(flds* ...) #'flds]
-                  [*maker (id #'nm "*" #'nm)]
-                  [**maker (id #'nm "**" #'nm)]
-                  [ht-stx ht-stx]
-                  [bfs-fold-rhs (cond [(and fold-rhs (eq? (syntax-e (stx-car fold-rhs)) '#:base))
-                                       #`(lambda (tr er) #,fold-target)]
-                                      [(and fold-rhs (stx-pair? fold-rhs))
-                                       (with-syntax ([fr (stx-car fold-rhs)])
-                                         #'(lambda (tr er) 
-                                             #'fr))]
-                                      [fold-rhs (raise-syntax-error fold-rhs "something went wrong")]
-                                      [else #'(lambda (type-rec-id effect-rec-id) 
-						#;
-                                                (printf "about to call ~a with ~a args~n"
-							'*maker
-							(length '(flds* ...)))
-						#`(*maker (#,type-rec-id flds*) ...))])]
-                  [provides (if provide? 
-                                #`(begin 
-                                    (provide ex pred acc ...)
-                                    (provide (rename-out [*maker maker])))
-                                #'(begin))]
-                  [intern (cond 
-                            [(syntax? intern?)
-                             #`(defintern (**maker key . flds) maker #,intern?)]                            
-                            [(null? (syntax-e #'flds))
-                             #'(defintern (**maker key . flds) maker #f)]
-                            [(stx-null? (stx-cdr #'flds)) #'(defintern (**maker key . flds) maker . flds)]
-                            [else #'(defintern (**maker key . flds) maker (list . flds))])]
-                  [frees (cond
-                           [(not frees) #'(begin)]
-                           ;; we know that this has no free vars
-                           [(and (pair? frees) (syntax? (car frees)) (not (syntax-e (car frees))))
-                            (syntax/loc stx
-                              (define (*maker . flds)
-                                (define v (**maker key-expr . flds)) 
-                                (unless-in-table 
-                                 var-table v
-                                 (hash-set! var-table v empty-hash-table)
-                                 (hash-set! index-table v empty-hash-table))
-                                v))]
-                           ;; we provided an expression each for calculating the free vars and free idxs
-                           ;; this should really be 2 expressions, one for each kind
-                           [(and (pair? frees) (pair? (cdr frees)))
-                            (quasisyntax/loc
-                                stx
-                              (define (*maker . flds)				
-                                (define v (**maker key-expr . flds))
-                                #,
-                                (quasisyntax/loc (car frees)
-                                  (unless-in-table 
-                                   var-table v
-                                   (hash-set! var-table v #,(car frees))
-                                   (hash-set! index-table v #,(cadr frees))))
-                                v))]                                       
-                           [else 
-                            (let 
-                                ([combiner 
-                                  (lambda (f flds)
-                                    (syntax-case flds ()
-                                      [() #'empty-hash-table]
-                                      [(e) #`(#,f e)]
-                                      [(e ...) #`(combine-frees (list (#,f e) ...))]))])
-                              (quasisyntax/loc stx
-                                (define (*maker . flds)
-                                  (define v (**maker key-expr . flds))
-                                  (unless-in-table 
-                                   var-table v
-                                   (define fvs #,(combiner #'free-vars* #'flds))
-                                   (define fis #,(combiner #'free-idxs* #'flds))
-                                   (hash-set! var-table v fvs)
-                                   (hash-set! index-table v fis))
-                                  v)))])])
-               #`(begin
-                   (define-struct (nm parent) flds #:inspector #f)
-                   (define-match-expander ex
-                     (lambda (s)
-                       (... 
-                        (syntax-case s ()
-                          [(__ . fs) 
-                           (with-syntax ([flds** (syntax/loc s (_ _ . fs))])
-                             (quasisyntax/loc s (struct nm flds**)))]))))
-                   (begin-for-syntax
-                     (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx)))
-                   intern
-                   provides
-                   frees)))])))
-    (values (mk #'Type #'type-name-ht) (mk #'Effect #'effect-name-ht))))
+        (syntax-parse stx 
+          [(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt 
+				     [[#:intern intern?:expr]] #:opt
+				     [[#:frees . frees:frees-pat]] #:opt
+				     [[#:fold-rhs fold-rhs:fold-pat]] #:opt
+				     [no-provide?:no-provide-kw] #:opt) ...*)
+	   (with-syntax* 
+	     ([ex (mk-id #'nm #'nm ":")]
+	      [kw-stx (string->keyword (symbol->string #'nm.datum))]
+	      [parent par]
+	      [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds) #f #t #'nm)]
+	      [*maker (mk-id #'nm "*" #'nm)]
+	      [**maker (mk-id #'nm "**" #'nm)]
+	      [ht-stx ht-stx]
+	      [bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)]
+				  [else #'(lambda (type-rec-id effect-rec-id) 
+					    #`(*maker (#,type-rec-id flds.i) ...))])]
+	      [provides (if #'no-provide?
+			    #'(begin)                                 
+			    #`(begin 
+				(provide ex pred acc ...)
+				(provide (rename-out [*maker maker]))))]
+	      [intern 
+	       (let ([mk (lambda (int) #`(defintern (**maker . flds) maker #,int #:extra-arg key-expr))])
+		 (syntax-parse #'flds
+		   [_ #:when #'intern?
+		    (mk #'intern?)]
+		   [() (mk #'#f)]
+		   [(f) (mk #'f)]
+		   [_ (mk #'(list . flds))]))]
+	      [frees 
+	       (with-syntax ([(f1 f2) (if #'frees
+					  #'(frees.f1 frees.f2)
+					  (list (combiner #'free-vars* #'flds)
+						(combiner #'free-idxs* #'flds)))])
+			    (quasisyntax/loc stx
+					     (define (*maker . flds)
+					       (define v (**maker . flds))
+					       (unless-in-table 
+						var-table v
+						(define fvs f1)
+						(define fis f2)
+						(hash-set! var-table v fvs)
+						(hash-set! index-table v fis))
+					       v)))])
+	     #`(begin
+		 (define-struct (nm parent) flds #:inspector #f)
+		 (define-match-expander ex
+		   (lambda (s)
+		     (syntax-parse s 
+		       [(_ . fs) 
+			#:with pat (syntax/loc s (_ _ . fs))
+			(syntax/loc s (struct nm pat))])))
+		 (begin-for-syntax
+		  (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx)))
+		 intern
+		 provides
+		 frees))])))
+  (values (mk #'Type #'type-name-ht) (mk #'Effect #'effect-name-ht))))