diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt
index 2851efd56f..b6f5cf92f8 100644
--- a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt
+++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt
@@ -112,11 +112,15 @@
    
    [(-values (list -Number)) (-values (list Univ))]
    
-   [(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number a) null #'values)) . -> . (-lst a)))
-    ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'values)) 
+   [(-poly (b) ((Un (make-Base 'foo #'dummy)
+                    (-struct 'bar #f 
+                             (list (make-fld -Number #'values #f) (make-fld b #'values #f))
+                             #'values))
+                . -> . (-lst b)))
+    ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values))
      . -> . (-lst (-pair -Number (-v a))))]
-   [(-poly (a) ((-struct 'bar #f (list -Number a) null #'values) . -> . (-lst a)))
-    ((-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'values) . -> . (-lst (-pair -Number (-v a))))]
+   [(-poly (b) ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values) . -> . (-lst b)))
+    ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values) . -> . (-lst (-pair -Number (-v a))))]
    
    [(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))]
    [(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-v b))))]
@@ -128,6 +132,9 @@
    (FAIL (-> Univ) (null Univ . ->* . Univ))
 
    [(cl->* (-Number . -> . -String) (-Boolean . -> . -String)) ((Un -Boolean -Number) . -> . -String)]
+   [(-struct 'a #f null #'values) (-struct 'a #f null #'values)]
+   [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld -String #'values #f)) #'values)]
+   [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld Univ #'values #f)) #'values)]
    ))
 
 (define-go 
diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt b/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt
index eaaa193971..3aa1b6f643 100644
--- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt
+++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt
@@ -24,6 +24,8 @@
        #'(test-suite "Tests for type equality"
                      cl1 ... cl2 ...))]))
 
+(define (fld* t) (make-fld t (datum->syntax #'here 'values) #f))
+
 (define (type-equal-tests)
   (te-tests
    [-Number -Number]
@@ -38,13 +40,12 @@
    ;; found bug
    [FAIL (Un (-mu heap-node 
                   (-struct 'heap-node #f
-                           (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty)))
-                           null #'values)) 
+                           (map fld* (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty))))
+                           #'values)) 
              (-base 'heap-empty))
          (Un (-mu heap-node 
                   (-struct 'heap-node #f
-                           (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))
-                           null #'values)) 
+                           (map fld* (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))) #'values))
              (-base 'heap-empty))]))
 
 (define-go
diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt
index c5c8e73790..caed2eb25a 100644
--- a/collects/typed-scheme/env/init-envs.rkt
+++ b/collects/typed-scheme/env/init-envs.rkt
@@ -25,11 +25,11 @@
     [(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))]
     [(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))]
     [(Name: stx) `(make-Name (quote-syntax ,stx))]
-    [(Struct: name parent flds proc poly? pred-id cert acc-ids maker-id)
+    [(fld: t acc mut) `(make-fld ,(sub t) (quote-syntax acc) ,mut)]
+    [(Struct: name parent flds proc poly? pred-id cert maker-id)
      `(make-Struct ,(sub name) ,(sub parent) 
                    ,(sub flds) ,(sub proc) ,(sub poly?)
                    (quote-syntax ,pred-id) (syntax-local-certifier)
-                   (list ,@(for/list ([a acc-ids]) `(quote-syntax ,a)))
                    (quote-syntax ,maker-id))]
     [(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))]
     [(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))]
diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt
index 2ae4d286a1..c4a0064a3a 100644
--- a/collects/typed-scheme/infer/infer-unit.rkt
+++ b/collects/typed-scheme/infer/infer-unit.rkt
@@ -13,7 +13,7 @@
 	 "signatures.rkt"                  
          scheme/match
          mzlib/etc
-         mzlib/trace racket/contract
+         racket/trace racket/contract
 	 unstable/sequence unstable/list unstable/debug unstable/hash
          scheme/list)
 
@@ -22,7 +22,7 @@
 
 (define (empty-set) '())  
 
-(define current-seen (make-parameter (empty-set) #;pair?))
+(define current-seen (make-parameter (empty-set)))
 
 (define (seen-before s t) (cons (Type-seq s) (Type-seq t)))
 (define (remember s t A) (cons (seen-before s t) A))
@@ -259,6 +259,15 @@
               (cset-meet* (list arg-mapping darg-mapping ret-mapping)))])]
     [(_ _) (fail! s-arr t-arr)]))
 
+(define (cgen/flds V X Y flds-s flds-t)
+  (cset-meet*
+   (for/list ([s (in-list flds-s)] [t (in-list flds-t)])
+     (match* (s t)
+       ;; mutable - invariant
+       [((fld: s _ #t) (fld: t _ #t)) (cset-meet (cgen V X Y s t) (cgen V X Y t s))]
+       ;; immutable - covariant
+       [((fld: s _ #f) (fld: t _ #f)) (cgen V X Y s t)]))))
+
 ;; V : a set of variables not to mention in the constraints
 ;; X : the set of type variables to be constrained
 ;; Y : the set of index variables to be constrained
@@ -328,13 +337,13 @@
           
           ;; two structs with the same name and parent
           ;; just check pairwise on the fields
-          ;; FIXME - wrong for mutable structs!
-          [((Struct: nm p flds proc _ _ _ _ _) (Struct: nm p flds* proc* _ _ _ _ _))
-           (let-values ([(flds flds*)
-                         (cond [(and proc proc*)
-                                (values (cons proc flds) (cons proc* flds*))]
-                               [else (values flds flds*)])])
-             (cgen/list V X Y flds flds*))]
+          [((Struct: nm p flds proc _ _ _ _) (Struct: nm p flds* proc* _ _ _ _))
+           (let ([proc-c
+                  (cond [(and proc proc*)
+                         (cg proc proc*)]
+                        [proc* (fail! S T)]
+                        [else empty])])
+             (cset-meet proc-c (cgen/flds V X Y flds flds*)))]
           
           ;; two struct names, need to resolve b/c one could be a parent
           [((Name: n) (Name: n*))
diff --git a/collects/typed-scheme/private/base-special-env.rkt b/collects/typed-scheme/private/base-special-env.rkt
index 0ccb7b2eb1..a643b15810 100644
--- a/collects/typed-scheme/private/base-special-env.rkt
+++ b/collects/typed-scheme/private/base-special-env.rkt
@@ -31,7 +31,7 @@
           (define-hierarchy child (spec ...) grand ...)
           ...)
        (begin
-         (d-s parent ([name : type] ...) ())
+         (d-s parent ([name : type] ...))
          (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...)
          ...)]))
 
diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt
index 26b5b0d7da..4d8d6bf8f0 100644
--- a/collects/typed-scheme/private/type-contract.rkt
+++ b/collects/typed-scheme/private/type-contract.rkt
@@ -30,7 +30,7 @@
   (syntax-parse stx #:literals (define-values)
     [(define-values (n) _)
      (let ([typ (if maker?
-                    ((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ)
+                    ((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ)
                     typ)])
        (with-syntax ([cnt (type->contract 
                            typ 
@@ -165,7 +165,7 @@
            #;#'class?           
            #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
         [(Value: '()) #'null?]
-        [(Struct: nm par flds proc poly? pred? cert acc-ids maker-id)
+        [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? cert maker-id)
          (cond 
            [(assf (λ (t) (type-equal? t ty)) structs-seen)
             =>
diff --git a/collects/typed-scheme/rep/rep-utils.rkt b/collects/typed-scheme/rep/rep-utils.rkt
index 3f78981349..36d5426415 100644
--- a/collects/typed-scheme/rep/rep-utils.rkt
+++ b/collects/typed-scheme/rep/rep-utils.rkt
@@ -252,17 +252,11 @@
                   [stx (or/c #f syntax?)]))
      [replace-syntax (Rep? syntax? . -> . Rep?)])
 
-
-(define (list-update l k v)
-  (if (zero? k)
-      (cons v (cdr l))
-      (cons (car l) (list-update (cdr l) (sub1 k) v))))
-
 (define (replace-field val new-val idx)
   (define-values (type skipped) (struct-info val))
   (define maker (struct-type-make-constructor type))
   (define flds (cdr (vector->list (struct->vector val))))
-  (apply maker (list-update flds idx new-val)))
+  (apply maker (list-set flds idx new-val)))
 
 (define (replace-syntax rep stx)
   (replace-field rep stx 3))
diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt
index d0c122f11d..203fb4bd85 100644
--- a/collects/typed-scheme/rep/type-rep.rkt
+++ b/collects/typed-scheme/rep/type-rep.rkt
@@ -14,6 +14,7 @@
      (and (Type? e)
           (not (Scope? e))
           (not (arr? e))
+          (not (fld? e))
           (not (Values? e))
           (not (ValuesDots? e))
           (not (Result? e)))))
@@ -224,21 +225,27 @@
     [#:fold-rhs (*Function (map type-rec-id arities))])
 
 
+(dt fld ([t Type/c] [acc identifier?] [mutable? boolean?])
+    [#:frees (λ (f) (if mutable? (make-invariant (f t)) (f t)))]
+    [#:fold-rhs (*fld (type-rec-id t) acc mutable?)]
+    [#:intern (list t (hash-id acc) mutable?)])
+
 ;; name : symbol
 ;; parent : Struct
-;; flds : Listof[Type]
+;; flds : Listof[fld]
 ;; proc : Function Type
 ;; poly? : is this a polymorphic type?
 ;; pred-id : identifier for the predicate of the struct
 ;; cert : syntax certifier for pred-id
-(dt Struct ([name symbol?] 
-            [parent (or/c #f Struct? Name?)] 
-            [flds (listof Type/c)]
+;; acc-ids : names of the accessors
+;; maker-id : name of the constructor
+(dt Struct ([name symbol?]
+            [parent (or/c #f Struct? Name?)]
+            [flds (listof fld?)]
             [proc (or/c #f Function?)]
             [poly? (or/c #f (listof symbol?))]
             [pred-id identifier?]
             [cert procedure?]
-            [acc-ids (listof identifier?)]
             [maker-id identifier?])
     [#:intern (list name parent flds proc)]
     [#:frees (λ (f) (combine-frees (map f (append (if proc (list proc) null)
@@ -251,7 +258,6 @@
                          poly?
                          pred-id
                          cert
-                         acc-ids
                          maker-id)]
     [#:key #f])
 
diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt
index b3e5794021..9644e5f21c 100644
--- a/collects/typed-scheme/typecheck/tc-app.rkt
+++ b/collects/typed-scheme/typecheck/tc-app.rkt
@@ -465,8 +465,11 @@
     [(#%plain-app (~and op (~or (~literal unsafe-struct-ref) (~literal unsafe-struct*-ref))) s e:expr)
      (let ([e-t (single-value #'e)])
        (match (single-value #'s)
-         [(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _)
-                                  (? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _))))))
+         [(tc-result1: 
+           (and t (or (Struct: _ _ (list (fld: flds _ muts) ...) _ _ _ _ _)
+                      (? needs-resolving? 
+                         (app resolve-once
+                              (Struct: _ _ (list (fld: flds _ muts) ...) _ _ _ _ _))))))
           (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
                           (match e-t
                             [(tc-result1: (Value: (? number? i))) i]
@@ -477,9 +480,11 @@
                        (check-below (ret (apply Un flds)) expected)
                        (ret (apply Un flds)))]
                   [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds))))
-                   (if expected
-                       (check-below (ret (list-ref flds ival)) expected)
-                       (ret (list-ref flds ival)))]
+                   (let ([result (if (list-ref muts ival)
+                                     (ret (list-ref flds ival))
+                                     ;; FIXME - could do something with paths here
+                                     (ret (list-ref flds ival)))])
+                     (if expected (check-below result expected) result))]
                   [(not (and (integer? ival) (exact? ival)))
                    (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for struct index, but got ~a" ival)]
                   [(< ival 0)
@@ -492,8 +497,10 @@
     [(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr)
      (let ([e-t (single-value #'e)])
        (match (single-value #'s)
-         [(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _)
-                                  (? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _))))))
+         [(tc-result1: (and t (or (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)
+                                  (? needs-resolving? 
+                                     (app resolve-once 
+                                          (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))))
           (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f])
                           (match e-t
                             [(tc-result1: (Value: (? number? i))) i]
@@ -916,7 +923,7 @@
                      (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected))))
                      t argtys expected)]
     ;; procedural structs
-    [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _ _))) _)
+    [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _)
      (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)]
     ;; parameters are functions too
     [((tc-result1: (Param: in out)) (list)) (ret out)]
diff --git a/collects/typed-scheme/typecheck/tc-envops.rkt b/collects/typed-scheme/typecheck/tc-envops.rkt
index 33410c7fe0..c7c59fb515 100644
--- a/collects/typed-scheme/typecheck/tc-envops.rkt
+++ b/collects/typed-scheme/typecheck/tc-envops.rkt
@@ -9,17 +9,13 @@
          (rep type-rep object-rep)
          (utils tc-utils)
          (types resolve)
-         (only-in (env type-env-structs lexical-env) env? update-type/lexical env-map env-props replace-props)
+         (only-in (env type-env-structs lexical-env) 
+                  env? update-type/lexical env-map env-props replace-props)
          scheme/contract scheme/match
          mzlib/trace unstable/debug unstable/struct
          (typecheck tc-metafunctions)
          (for-syntax scheme/base))
 
-(define (replace-nth l i f)
-  (cond [(null? l) (error 'replace-nth "list not long enough" l i f)]
-        [(zero? i) (cons (f (car l)) (cdr l))]
-        [else (cons (car l) (replace-nth (cdr l) (sub1 i) f))]))
-
 ;(trace replace-nth)
 
 (define/contract (update t lo)
@@ -42,15 +38,25 @@
      (make-Syntax (update t (-not-filter u x rst)))]
     
     ;; struct ops
-    [((Struct: nm par flds proc poly pred cert acc-ids maker-id) 
+    [((Struct: nm par flds proc poly pred cert maker-id) 
       (TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))     
      (make-Struct nm par 
-                  (replace-nth flds idx 
-                               (lambda (e) (update e (-filter u x rst))))
-                  proc poly pred cert acc-ids maker-id)]
-    [((Struct: nm par flds proc poly pred cert acc-ids maker-id) 
+                  (list-update flds idx 
+                            (match-lambda [(fld: e acc-id #f) 
+                                           (make-fld
+                                            (update e (-filter u x rst))
+                                            acc-id #f)]
+                                          [_ (int-err "update on mutable struct field")]))
+                  proc poly pred cert maker-id)]
+    [((Struct: nm par flds proc poly pred cert maker-id) 
       (NotTypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
-     (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (-not-filter u x rst)))) proc poly pred cert acc-ids maker-id)]
+     (make-Struct nm par (list-update flds idx 
+                                      (match-lambda [(fld: e acc-id #f) 
+                                                     (make-fld
+                                                      (update e (-not-filter u x rst))
+                                                      acc-id #f)]
+                                          [_ (int-err "update on mutable struct field")]))
+                  proc poly pred cert maker-id)]
     
     ;; otherwise
     [(t (TypeFilter: u (list) _))
diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt
index 1942898d80..c43bce64cb 100644
--- a/collects/typed-scheme/typecheck/tc-structs.rkt
+++ b/collects/typed-scheme/typecheck/tc-structs.rkt
@@ -13,6 +13,10 @@
          unstable/debug
          racket/function
          scheme/match
+         (only-in racket/contract
+                  listof any/c or/c
+                  [->* c->*]
+                  [-> c->])
          (for-syntax scheme/base))
 
 
@@ -78,35 +82,54 @@
 ;; Option[Struct-Ty] -> Listof[Type]
 (define (get-parent-flds p)
   (match p
-    [(Struct: _ _ flds _ _ _ _ _ _) flds]
+    [(Struct: _ _ flds _ _ _ _ _) flds]
     [(Name: n) (get-parent-flds (lookup-type-name n))]
     [#f null]))
 
 
 ;; construct all the various types for structs, and then register the approriate names
-;; identifier listof[identifier] type listof[Type] listof[Type] boolean -> Type listof[Type] listof[Type]
-(define (mk/register-sty nm flds parent parent-field-types types 
-                         #:wrapper [wrapper values] 
-                         #:type-wrapper [type-wrapper values]
-                         #:pred-wrapper [pred-wrapper values]
-                         #:mutable [setters? #f]
-                         #:struct-info [si #f]
-                         #:proc-ty [proc-ty #f]
-                         #:maker [maker* #f]
-                         #:predicate [pred* #f]
-                         #:constructor-return [cret #f]
-                         #:poly? [poly? #f]
-                         #:type-only [type-only #f])
+;; identifier listof[identifier] type listof[fld] listof[Type] boolean -> Type listof[Type] listof[Type]
+(d/c (mk/register-sty nm flds parent parent-fields types 
+                      #:wrapper [wrapper values] 
+                      #:type-wrapper [type-wrapper values]
+                      #:pred-wrapper [pred-wrapper values]
+                      #:mutable [setters? #f]
+                      #:struct-info [si #f]
+                      #:proc-ty [proc-ty #f]
+                      #:maker [maker* #f]
+                      #:predicate [pred* #f]
+                      #:constructor-return [cret #f]
+                      #:poly? [poly? #f]
+                      #:type-only [type-only #f])
+     (c->* (identifier? (listof identifier?) (or/c Type/c #f) (listof fld?) (listof Type/c)) 
+           (#:wrapper procedure?
+            #:type-wrapper procedure?
+            #:pred-wrapper procedure?
+            #:mutable boolean?
+            #:struct-info any/c
+            #:proc-ty (or/c #f Type/c)
+            #:maker (or/c #f identifier?)
+            #:predicate (or/c #f identifier?)
+            #:constructor-return (or/c #f Type/c)
+            #:poly? (or/c #f (listof symbol?))
+            #:type-only boolean?)
+           any/c)
   ;; create the approriate names that define-struct will bind
   (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
   (let* ([name (syntax-e nm)]
-         [fld-types (append parent-field-types types)]
-         [sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters (or maker* maker))]
+         [fld-names flds]
+         [this-flds (for/list ([t (in-list types)]
+                               [g (in-list getters)])
+                       (make-fld t g setters?))]
+         [flds (append parent-fields this-flds)]
+         [sty (make-Struct name parent flds proc-ty poly? pred
+                           (syntax-local-certifier) (or maker* maker))]
          [external-fld-types/no-parent types]
-         [external-fld-types fld-types])
+         [external-fld-types (map fld-t flds)])
     (if type-only
         (register-type-name nm (wrapper sty))
-        (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? 
+        (register-struct-types nm sty fld-names external-fld-types
+                               external-fld-types/no-parent setters? 
                                #:wrapper wrapper
                                #:type-wrapper type-wrapper
                                #:pred-wrapper pred-wrapper
@@ -119,15 +142,25 @@
 ;; generate names, and register the approriate types give field types and structure type
 ;; optionally wrap things
 ;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier
-(define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
-                               #:wrapper [wrapper values]
-                               #:struct-info [si #f]
-                               #:type-wrapper [type-wrapper values]
-                               #:pred-wrapper [pred-wrapper values]
-                               #:maker [maker* #f]
-                               #:predicate [pred* #f]
-                               #:poly? [poly? #f]
-                               #:constructor-return [cret #f])
+(d/c (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
+                            #:wrapper [wrapper values]
+                            #:struct-info [si #f]
+                            #:type-wrapper [type-wrapper values]
+                            #:pred-wrapper [pred-wrapper values]
+                            #:maker [maker* #f]
+                            #:predicate [pred* #f]
+                            #:poly? [poly? #f]
+                            #:constructor-return [cret #f])
+     (c->* (identifier? Struct? (listof identifier?) (listof Type/c) (listof Type/c) boolean?)
+           (#:wrapper procedure?
+            #:type-wrapper procedure?
+            #:pred-wrapper procedure?
+            #:struct-info any/c
+            #:maker (or/c #f identifier?)
+            #:predicate (or/c #f identifier?)
+            #:constructor-return (or/c #f Type/c)
+            #:poly? (or/c #f (listof symbol?)))
+           list?)
   ;; create the approriate names that define-struct will bind
   (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
   ;; the type name that is used in all the types
@@ -212,10 +245,18 @@
 
 ;; typecheck a non-polymophic struct and register the approriate types
 ;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
-(define (tc/struct nm/par flds tys [proc-ty #f] 
-                   #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
-                   #:predicate [pred #f]
-                   #:type-only [type-only #f])
+(d/c (tc/struct nm/par flds tys [proc-ty #f] 
+                #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
+                #:predicate [pred #f]
+                #:type-only [type-only #f])
+     (c->* (syntax? (listof identifier?) (listof syntax?))
+           ((or/c #f syntax?)
+            #:maker any/c
+            #:mutable boolean?
+            #:constructor-return any/c
+            #:predicate any/c
+            #:type-only boolean?)
+           any/c)
   ;; get the parent info and create some types and type variables
   (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
   ;; parse the field types, and determine if the type is recursive
@@ -239,9 +280,13 @@
 ;; register a struct type
 ;; convenience function for built-in structs
 ;; tc/builtin-struct : identifier identifier Listof[identifier] Listof[Type] Listof[Type] -> void
-(define (tc/builtin-struct nm parent flds tys parent-tys)
-  (let ([parent* (if parent (make-Name parent) #f)])
-    (mk/register-sty nm flds parent* parent-tys tys
+(d/c (tc/builtin-struct nm parent flds tys #;parent-tys)
+     (c-> identifier? (or/c #f identifier?) (listof identifier?)
+          (listof Type/c) #;(listof fld?)
+          any/c)
+  (let* ([parent-name (if parent (make-Name parent) #f)]
+         [parent-flds (if parent (get-parent-flds parent-name) null)])
+    (mk/register-sty nm flds parent-name parent-flds tys
                      #:mutable #t)))
 
 ;; syntax for tc/builtin-struct
@@ -250,11 +295,9 @@
     [(_ (nm par) ([fld : ty] ...) (par-ty ...))
      #'(tc/builtin-struct #'nm #'par
                           (list #'fld ...)
-                          (list ty ...)
-                          (list par-ty ...))]
-    [(_ nm ([fld : ty] ...) (par-ty ...))
+                          (list ty ...))]
+    [(_ nm ([fld : ty] ...))
      #'(tc/builtin-struct #'nm #f
                           (list #'fld ...)
-                          (list ty ...)
-                          (list par-ty ...))]))
+                          (list ty ...))]))
 
diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt
index 3b6d5d14e8..5acdfdbb4a 100644
--- a/collects/typed-scheme/typecheck/tc-toplevel.rkt
+++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt
@@ -72,7 +72,7 @@
       
       [(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values)))
        (let* ([t (parse-type #'ty)]
-              [flds (Struct-flds (lookup-type-name (Name-id t)))]
+              [flds (map fld-t (Struct-flds (lookup-type-name (Name-id t))))]
               [mk-ty (flds #f . ->* . t)])
          (register-type #'nm mk-ty)
          (list (make-def-binding #'nm mk-ty)))]
diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt
index 3e3533171c..53c6ba84ce 100644
--- a/collects/typed-scheme/types/abbrev.rkt
+++ b/collects/typed-scheme/types/abbrev.rkt
@@ -86,12 +86,12 @@
 
 ;; basic types
 
-(define promise-str (string->uninterned-symbol "Promise"))
+(define promise-sym (string->uninterned-symbol "Promise"))
 
 (define make-promise-ty
-  (let ([s promise-str])
+  (let ([s promise-sym])
     (lambda (t)
-      (make-Struct s #f (list t) #f #f #'promise? values (list #'values) #'values))))
+      (make-Struct s #f (list (make-fld t #'values #f)) #f #f #'promise? values #'values))))
 
 (define -Listof (-poly (list-elem) (make-Listof list-elem)))
 
@@ -285,8 +285,8 @@
 (define (make-arr-dots dom rng dty dbound)
   (make-arr* dom rng #:drest (cons dty dbound)))
 
-(define (-struct name parent flds accs constructor [proc #f] [poly #f] [pred #'dummy] [cert values])
-  (make-Struct name parent flds proc poly pred cert accs constructor))
+(define (-struct name parent flds constructor [proc #f] [poly #f] [pred #'dummy] [cert values])
+  (make-Struct name parent flds proc poly pred cert constructor))
 
 (d/c (-filter t i [p null])
      (c:->* (Type/c name-ref/c) ((listof PathElem?)) Filter/c)
diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt
index ebfe338878..0c4ada2724 100644
--- a/collects/typed-scheme/types/printer.rkt
+++ b/collects/typed-scheme/types/printer.rkt
@@ -144,9 +144,9 @@
      (fp "~a" (cons 'List (tuple-elems t)))]
     [(Base: n cnt) (fp "~a" n)]      
     [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))]
-    [(Struct: (== promise-str eq?) #f  (list fld) _    _ _ _ _ _) (fp "(Promise ~a)" fld)]
-    [(Struct: nm       par flds       proc _ _ _ _ _)
-     (fp "#(struct:~a ~a" nm flds)
+    [(Struct: (== promise-sym) #f  (list (fld: t _ _)) _    _ _ _ _) (fp "(Promise ~a)" t)]
+    [(Struct: nm       par (list (fld: t _ _) ...)       proc _ _ _ _)
+     (fp "#(struct:~a ~a" nm t)
      (when proc
        (fp " ~a" proc))
      (fp ")")]
@@ -223,6 +223,7 @@
      (for ([t ts]) (fp " ~a" t))
      (fp ")")]
     [(Error:) (fp "Error")]
+    [(fld: t a m) (fp "(fld ~a)" t)]
     [else (fp "(Unknown Type: ~a)" (struct->vector c))]
     ))
 
diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt
index af4e5d5492..a646a54cda 100644
--- a/collects/typed-scheme/types/remove-intersect.rkt
+++ b/collects/typed-scheme/types/remove-intersect.rkt
@@ -50,25 +50,30 @@
          [(or (list (Pair: _ _) _)
               (list _ (Pair: _ _)))
           #f]
-         [(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _ _))
-              (list (Struct: n _ flds _ _ _ _ _ _) (Value: '())))
+         [(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _))
+              (list (Struct: n _ flds _ _ _ _ _) (Value: '())))
           #f]
-         [(list (Struct: n _ flds _ _ _ _ _ _)
-                (Struct: n _ flds* _ _ _ _ _ _))
-          (for/and ([f flds] [f* flds*]) (overlap f f*))]
-         [(list (Struct: n #f _ _ _ _ _ _ _)
-                (StructTop: (Struct: n #f _ _ _ _ _ _ _)))
+         [(list (Struct: n _ flds _ _ _ _ _)
+                (Struct: n _ flds* _ _ _ _ _))
+          (for/and ([f flds] [f* flds*]) 
+            (match* (f f*)
+              [((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))]
+         [(list (Struct: n #f _ _ _ _ _ _)
+                (StructTop: (Struct: n #f _ _ _ _ _ _)))
           #t]
          ;; n and n* must be different, so there's no overlap
-         [(list (Struct: n #f flds _ _ _ _ _ _)
-                (Struct: n* #f flds* _ _ _ _ _ _))
+         [(list (Struct: n #f flds _ _ _ _ _)
+                (Struct: n* #f flds* _ _ _ _ _))
           #f]
-         [(list (Struct: n #f flds _ _ _ _ _ _)
-                (StructTop: (Struct: n* #f flds* _ _ _ _ _ _)))
+         [(list (Struct: n #f flds _ _ _ _ _)
+                (StructTop: (Struct: n* #f flds* _ _ _ _ _)))
           #f]
-         [(list (Struct: n p flds _ _ _ _ _ _)
-                (Struct: n* p* flds* _ _ _ _ _ _))
-          (and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))]
+         [(list (Struct: n p flds _ _ _ _ _)
+                (Struct: n* p* flds* _ _ _ _ _))
+          (and (= (length flds) (length flds*)) 
+               (for/and ([f flds] [f* flds*]) 
+                 (match* (f f*)
+                   [((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))]
          [(list (== (-val eof))
                 (Function: _))
           #f]
diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt
index a5167c4867..aee5118772 100644
--- a/collects/typed-scheme/types/subtype.rkt
+++ b/collects/typed-scheme/types/subtype.rkt
@@ -16,7 +16,7 @@
 
 (define-struct (exn:subtype exn:fail) (s t))
 
-;; inference failure - masked before it gets to the user program
+;; subtyping failure - masked before it gets to the user program
 (define-syntax fail!
   (syntax-rules ()
     [(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))]))
@@ -196,6 +196,13 @@
        [else (make-arr (apply map (lambda args (make-Union (sort args type<?))) (cons dom1 dom)) rng1 #f #f '())])]
     [_ #f]))
 
+(define (subtype/flds* A flds flds*)
+  (for/fold ([A A]) ([f (in-list flds)] [f* (in-list flds*)])
+    (match* (f f*)
+      [((fld: t _ #t) (fld: t* _ #t))
+       (subtype* (subtype* A t* t) t t*)]
+      [((fld: t _ #f) (fld: t* _ #f))
+       (subtype* A t t*)])))
 
 ;; the algorithm for recursive types transcribed directly from TAPL, pg 305
 ;; List[(cons Number Number)] type type -> List[(cons Number Number)]
@@ -347,12 +354,13 @@
                                    (fail! s t))]
 	      [(s (Union: es)) (or (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0)
                                    (fail! s t))]
-	      ;; subtyping on immutable structs is covariant
-	      [((Struct: nm _ flds #f _ _ _ _ _) (Struct: nm _ flds* #f _ _ _ _ _))
-	       (subtypes* A0 flds flds*)]
-	      [((Struct: nm _ flds proc _ _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _ _))
-	       (subtypes* A0 (cons proc flds) (cons proc* flds*))]
-              [((Struct: _ _ _ _ _ _ _ _ _) (StructTop: (? (lambda (s2) (type-equal? s2 s)))))
+	      ;; subtyping on immutable structs is covariant	      
+	      [((Struct: nm _ flds proc _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _))
+               (let ([A (cond [(and proc proc*) (subtype* proc proc*)]
+                              [proc* (fail! proc proc*)]
+                              [else A0])])
+                 (subtype/flds* A flds flds*))]
+              [((Struct: _ _ _ _ _ _ _ _) (StructTop: (== s type-equal?)))
                A0]
               [((Box: _) (BoxTop:)) A0]
               [((Channel: _) (ChannelTop:)) A0]
@@ -363,11 +371,11 @@
               [((MPair: _ _) (MPairTop:)) A0]
               [((Hashtable: _ _) (HashtableTop:)) A0]
 	      ;; subtyping on structs follows the declared hierarchy
-	      [((Struct: nm (? Type? parent) flds proc _ _ _ _ _) other) 
+	      [((Struct: nm (? Type? parent) flds proc _ _ _ _) other) 
                ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other)
 	       (subtype* A0 parent other)]
 	      ;; Promises are covariant
-	      [((Struct: 'Promise _ (list t) _ _ _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _ _ _)) (subtype* A0 t t*)]
+	      [((Struct: (== promise-sym) _ (list t) _ _ _ _ _) (Struct: (== promise-sym) _ (list t*) _ _ _ _ _)) (subtype* A0 t t*)]
 	      ;; subtyping on values is pointwise
 	      [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)]
               ;; trivial case for Result
diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt
index 4c81ab3fb3..37d4026673 100644
--- a/collects/typed-scheme/utils/utils.rkt
+++ b/collects/typed-scheme/utils/utils.rkt
@@ -11,7 +11,7 @@ at least theoretically.
 	 scheme/pretty mzlib/pconvert syntax/parse)
 
 ;; to move to unstable
-(provide reverse-begin)
+(provide reverse-begin list-update list-set)
 
 (provide
  ;; optimization
@@ -26,6 +26,7 @@ at least theoretically.
  rep utils typecheck infer env private types)
 
 (define optimize? (make-parameter #f))
+(define-for-syntax enable-contracts? #t)
 
 ;; fancy require syntax
 (define-syntax (define-requirer stx)
@@ -159,7 +160,6 @@ at least theoretically.
 
 
 ;; turn contracts on and off - off by default for performance.
-(define-for-syntax enable-contracts? #f)
 (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c d/c/p)
 
 (define-syntax-rule (d/c/p (name . args) c . body)
@@ -214,3 +214,13 @@ at least theoretically.
      (if enable-contracts?
          (list #'[contracted (nm cnt)])     
          (list #'nm))]))
+
+(define (list-update l i f)
+  (cond [(null? l) (error 'list-update "list not long enough" l i f)]
+        [(zero? i) (cons (f (car l)) (cdr l))]
+        [else (cons (car l) (list-update (cdr l) (sub1 i) f))]))
+
+(define (list-set l k v)
+  (if (zero? k)
+      (cons v (cdr l))
+      (cons (car l) (list-set (cdr l) (sub1 k) v))))