diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
index 89159bb4a2..52f579cfe9 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
@@ -2051,20 +2051,66 @@
          [x 2]))
   
   (test/spec-passed/result
-   'class-field-accessor
+   'class-field-accessor1
    '(let ([c% (class object% (super-new) (field [f 1]))])
-      ((class-field-accessor c% f) 
+      ((class-field-accessor c% f)
        (new (contract (class/c) c% 'pos 'neg))))
    1)
   
+  (test/spec-passed
+   'class-field-accessor2
+   '(let* ([c% (class object% (field [f 1]) (super-new))]
+           [c+c% (contract (class/c (field [f integer?])) c% 'pos 'neg)])
+      ((class-field-accessor c+c% f) (new c%))))
+  
+  (test/pos-blame
+   'class-field-accessor3
+   '(let* ([c% (class object% (field [f #f]) (super-new))]
+           [c+c% (contract (class/c (field [f integer?])) c% 'pos 'neg)])
+      ((class-field-accessor c+c% f) (new c%))))
+  
+  (test/spec-passed
+   'class-field-accessor4
+   '(let* ([c% (class object% (field [f #f]) (super-new))]
+           [c+c% (contract (class/c (field [f integer?])) c% 'pos 'neg)])
+      ((class-field-accessor c% f) (new c+c%))))
+  
   (test/spec-passed/result
-   'class-field-mutator
+   'class-field-mutator1
    '(let* ([c% (class object% (super-new) (field [f 1]))]
            [o (new (contract (class/c) c% 'pos 'neg))])
       ((class-field-mutator c% f) o 2)
       ((class-field-accessor c% f) o))
    2)
   
+  (test/spec-passed/result
+   'class-field-mutator2
+   '(let* ([c% (class object% (super-new) (field [f 1]))]
+           [o (new (contract (class/c (field [f boolean?])) c% 'pos 'neg))])
+      ((class-field-mutator c% f) o #f)
+      ((class-field-accessor c% f) o))
+   #f)
+  
+  (test/spec-passed
+   'class-field-mutator3 
+   '(let* ([c% (class object% (super-new) (field [f 1]))]
+           [o (new (contract (class/c (field [f boolean?])) c% 'pos 'neg))])
+      ((class-field-mutator c% f) o 11)))
+  
+  (test/neg-blame
+   'class-field-mutator4
+   '(let* ([c% (class object% (super-new) (field [f 1]))]
+           [c%+c (contract (class/c (field [f boolean?])) c% 'pos 'neg)]
+           [o (new c%+c)])
+      ((class-field-mutator c%+c f) o 11)))
+  
+  (test/neg-blame
+   'class-field-mutator5
+   '(let* ([c% (class object% (super-new) (field [f 1]))]
+           [c%+c (contract (class/c (field [f boolean?])) c% 'pos 'neg)]
+           [o (new c%)])
+      ((class-field-mutator c%+c f) o 11)))
+  
   (test/spec-passed/result
    'order-of-evaluation
    '(let ([x '()])
@@ -2360,6 +2406,70 @@
            [sub-c% (class c% (super-new))])
       (new sub-c% [f 1])))
   
+  (test/neg-blame
+   'subclass-and-external-contracts6
+   '(let* ([c% (contract (class/c (init [f integer?]))
+                         (class object% (init f) (super-new))
+                         'pos 'neg)]
+           [sub-c% (class c% (super-new))])
+      (new sub-c% [f #f])))
+  
+  (test/spec-passed
+   'subclass-and-external-contracts7
+   '(let* ([c% (contract (class/c (init [i integer?]))
+                         (class object% (init i) (super-new))
+                         'pos 'neg)]
+           [sub-c% (class c% (init i) (super-new [i 2]))])
+      (new sub-c% [i #f])))
+  
+  (test/neg-blame
+   'subclass-and-external-contracts8
+   '(let* ([c%
+            (contract (class/c (init [i integer?]))
+                      (class object% (init i) (super-new))
+                      'pos 'neg)]
+            [d% (class c% (super-new [i #f]))])
+      (new d%)))
+  
+  (test/spec-passed
+   'subclass-and-external-contracts9
+   '(let* ([c%
+            (contract (class/c (init [i integer?] [j integer?]))
+                      (class object% (init i) (init j) (super-new))
+                      'pos 'neg)]
+            [d% (class c% (init i) (super-new [i 1]))])
+      (new d% [i #f] [j 1])))
+  
+  (test/neg-blame
+   'subclass-and-external-contracts10
+   '(let* ([c%
+            (contract (class/c (init [i integer?] [j integer?]))
+                      (class object% (init i) (init j) (super-new))
+                      'pos 'neg)]
+           [d% (class c% (init i) (super-new [i 1]))])
+      (new d% [i #f] [j #f])))
+  
+  (test/spec-passed/result
+   'object=?
+   '(let ([o (new (contract (class/c (m (->m integer? integer?)))
+                            (class object%
+                              (define/public (m x) x)
+                              (define/public (get-this) this)
+                              (super-new))
+                            'pos 'neg))])
+      (object=? (send o get-this) o))
+   #t)
+
+  ;; this test case won't pass until the internal-ctc
+  ;; call is delayed in the new class/c projections
+  ;; (but otherwise it passes)
+  #;
+  (test/spec-passed/result
+   'chaperone-of
+   '(let* ([c% (class object% (define/public (m x) x))]
+           [c+c% (contract (class/c (m (->m integer? integer?))) c% 'pos 'neg)])
+      (chaperone-of? c+c% c%))
+   #t)
   
   (let ([expected-given?
          (λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt
index b718aad5c4..5bc805493a 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt
@@ -334,6 +334,24 @@
               (class/c [m (->dm ([d integer?]) () [r integer?])]))
   (test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])])
                      c%/c))
+  (test-name '(class/c (field [f integer?])) (class/c (field [f integer?])))
+  (test-name '(class/c (field [f integer?])) (class/c (field [f integer?])))
+  (test-name '(class/c (init-field [f integer?])) (class/c (init-field [f integer?])))
+  (test-name '(class/c (inherit-field [f integer?])) (class/c (inherit-field [f integer?])))
+  (test-name '(class/c (absent a b c (field d e f))) (class/c (absent a b c (field d e f))))
+  (test-name '(class/c (absent a b c)) (class/c (absent a b c)))
+  (test-name '(class/c (inherit [f integer?])
+                       (super [m (->m (<=/c 0) integer?)])
+                       (inner [n (->m (<=/c 1) integer?)])
+                       (override [o (->m (<=/c 2) integer?)])
+                       (augment [p (->m (<=/c 3) integer?)])
+                       (augride [q (->m (<=/c 4) integer?)]))
+             (class/c (inherit [f integer?])
+                      (super [m (->m (<=/c 0) integer?)])
+                      (inner [n (->m (<=/c 1) integer?)])
+                      (override [o (->m (<=/c 2) integer?)])
+                      (augment [p (->m (<=/c 3) integer?)])
+                      (augride [q (->m (<=/c 4) integer?)])))
 
   (test-name '(struct/dc s
                          [a integer?]
diff --git a/racket/collects/racket/class.rkt b/racket/collects/racket/class.rkt
index ef06d2510e..a3be91a65b 100644
--- a/racket/collects/racket/class.rkt
+++ b/racket/collects/racket/class.rkt
@@ -6,7 +6,8 @@
 ;; All of the implementation is actually in private/class-internal.rkt,
 ;;  which provides extra (private) functionality to contract.rkt.
 (require "private/class-internal.rkt"
-         "private/class-c-old.rkt")
+         (except-in "private/class-c-old.rkt" class/c)
+         (rename-in "private/class-c-new.rkt" [class/c2 class/c]))
   
 (provide-public-names)
 (provide generic?)
diff --git a/racket/collects/racket/private/class-c-new.rkt b/racket/collects/racket/private/class-c-new.rkt
index ddd1c141c3..3a0020eba6 100644
--- a/racket/collects/racket/private/class-c-new.rkt
+++ b/racket/collects/racket/private/class-c-new.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 (require "class-internal.rkt"
          "class-c-old.rkt"
+         "class-wrapped.rkt"
          "../contract/base.rkt"
          "../contract/combinator.rkt"
          (only-in "../contract/private/guts.rkt"
@@ -88,6 +89,27 @@
               (neg-accepter #f)
               (k neg-accepter)))
         (cond
+          [(impersonator-prop:has-wrapped-class-neg-party? cls)
+           (define wrapper-neg-party (impersonator-prop:get-wrapped-class-neg-party cls))
+           (define the-info (impersonator-prop:get-wrapped-class-info cls))
+           (define neg-acceptors (wrapped-class-info-neg-acceptors-ht the-info))
+           (define mth->idx (class-method-ht cls))
+           (define new-mths (make-vector (vector-length (class-methods cls)) #f))
+           (for ([(mth neg-acceptor) (in-hash neg-acceptors)])
+             (define mth-idx (hash-ref mth->idx mth))
+             (vector-set! new-mths mth-idx (neg-acceptor wrapper-neg-party)))
+           (define fixed-neg-init-projs
+             (for/list ([proj-pair (wrapped-class-info-init-proj-pairs the-info)])
+               (cons (list-ref proj-pair 0)
+                     (for/list ([func (in-list (cdr proj-pair))])
+                       (λ (val) (λ (neg-party) 
+                                  ((func val) wrapper-neg-party)))))))
+           (build-neg-acceptor-proc this maybe-err blame 
+                                    cls
+                                    new-mths
+                                    fixed-neg-init-projs
+                                    (wrapped-class-info-pos-field-projs the-info)
+                                    (wrapped-class-info-neg-field-projs the-info))]
           [(class-struct-predicate? cls)
            (define mtd-vec (class-methods cls))
            (cond
@@ -142,28 +164,6 @@
              [else 
               (build-neg-acceptor-proc this maybe-err blame cls #f '() 
                                        (make-hasheq) (make-hasheq))])]
-          [(wrapped-class? cls) 
-           (define wrapper-neg-party (wrapped-class-neg-party cls))
-           (define the-info (wrapped-class-the-info cls))
-           (define neg-acceptors (wrapped-class-info-neg-acceptors-ht the-info))
-           (define real-class (wrapped-class-info-class the-info))
-           (define mth->idx (class-method-ht real-class))
-           (define new-mths (make-vector (vector-length (class-methods real-class)) #f))
-           (for ([(mth neg-acceptor) (in-hash neg-acceptors)])
-             (define mth-idx (hash-ref mth->idx mth))
-             (vector-set! new-mths mth-idx (neg-acceptor wrapper-neg-party)))
-           (define fixed-neg-init-projs
-             (for/list ([proj-pair (wrapped-class-info-init-proj-pairs the-info)])
-               (cons (list-ref proj-pair 0)
-                     (for/list ([func (in-list (cdr proj-pair))])
-                       (λ (val) (λ (neg-party) 
-                                  ((func val) wrapper-neg-party)))))))
-           (build-neg-acceptor-proc this maybe-err blame 
-                                    (wrapped-class-info-class the-info)
-                                    new-mths
-                                    fixed-neg-init-projs
-                                    (wrapped-class-info-pos-field-projs the-info)
-                                    (wrapped-class-info-neg-field-projs the-info))]
           [else
            (maybe-err
             (λ (neg-party)
@@ -308,9 +308,14 @@
                 ((get/build-val-first-projection ctc) 
                  (blame-add-init-context blame (car ctc-pair)))))))
   (define merged-init-pairs (merge-init-pairs old-init-pairs new-init-projs))
-  (define the-info (wrapped-class-info cls blame neg-extra-arg-vec neg-acceptors-ht
+  (define the-info (wrapped-class-info blame neg-extra-arg-vec neg-acceptors-ht
                                        pos-field-projs neg-field-projs
                                        merged-init-pairs))
+  (define class+one-property 
+    (chaperone-struct cls
+                        set-class-orig-cls! (λ (a b) b)
+                        impersonator-prop:wrapped-class-info
+                        the-info))
   
   (λ (neg-party)
     ;; run this for the side-effect of 
@@ -324,13 +329,17 @@
     ;; the internal projection should run
     ;; on the class only when it is
     ;; time to instantiate it; not here
-    (define the-info/adjusted-cls
-      (struct-copy wrapped-class-info
-                   the-info
-                   [class ((internal-proj (blame-add-missing-party blame neg-party))
-                           cls)]))
+    (define class+one-property/adjusted
+      (chaperone-struct ((internal-proj (blame-add-missing-party blame neg-party))
+                         cls)
+                        set-class-orig-cls! (λ (a b) b)
+                        impersonator-prop:wrapped-class-info
+                        the-info))
     
-    (wrapped-class the-info/adjusted-cls neg-party)))
+    (chaperone-struct class+one-property/adjusted
+                      set-class-orig-cls! (λ (a b) b)
+                      impersonator-prop:wrapped-class-neg-party
+                      neg-party)))
 
 (define (merge-init-pairs old-init-pairs new-init-pairs)
   (cond
@@ -437,19 +446,54 @@
      (cond
        [(ext-class/c-contract-name c) => values]
        [else
+        (define field-names
+          (for/list ([(fld ctc) (in-hash (ext-class/c-contract-table-of-flds-to-ctcs c))])
+            `(,fld ,(contract-name ctc))))
+        (define init-fields '())
         (define init-names
-          (for/list ([pr (in-list (ext-class/c-contract-init-ctc-pairs c))])
-            (define name (list-ref pr 0))
-            (define ctc (list-ref pr 1))
-            (if (just-check-existence? ctc)
-                name
-                `[,name ,(contract-name ctc)])))
+          (filter
+           values
+           (for/list ([pr (in-list (ext-class/c-contract-init-ctc-pairs c))])
+             (define name (list-ref pr 0))
+             (define ctc (list-ref pr 1))
+             (cond
+               [(just-check-existence? ctc)
+                name]
+               [else 
+                (define c-name (contract-name ctc))
+                (define clause `[,name ,c-name])
+                (define fld-ctc (hash-ref (ext-class/c-contract-table-of-flds-to-ctcs c) name #f))
+                (cond
+                  [(and fld-ctc (equal? c-name (contract-name fld-ctc)))
+                   (set! init-fields (cons clause init-fields))
+                   #f]
+                  [else clause])]))))
+        (set! field-names (filter (λ (x) (not (member (car x) (map car init-fields))))
+                                  field-names))
+        
         (define meth-names
           (for/list ([(name ctc) (in-hash (ext-class/c-contract-table-of-meths-to-ctcs c))])
             (if (just-check-existence? ctc)
                 name
                 `[,name ,(contract-name ctc)])))
+        
+        (define absents
+          (let ([ams (ext-class/c-contract-absent-methods c)]
+                [afs (ext-class/c-contract-absent-fields c)])
+            (cond
+              [(and (null? ams) (null? afs)) '()]
+              [(null? afs) (list `(absent ,@ams))]
+              [else (list `(absent ,@ams (field ,@afs)))])))
+        
         `(class/c ,@(if (null? init-names)
                         (list)
                         (list `(init ,@init-names)))
-                  ,@meth-names)]))))
+                  ,@(if (null? field-names)
+                        (list)
+                        (list `(field ,@field-names)))
+                  ,@(if (null? init-fields)
+                        (list)
+                        (list `(init-field ,@init-fields)))
+                  ,@meth-names
+                  ,@absents
+                  ,@(class/c-internal-name-clauses (ext-class/c-contract-internal-ctc c)))]))))
diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt
index 47391c0f8d..cd869f310a 100644
--- a/racket/collects/racket/private/class-c-old.rkt
+++ b/racket/collects/racket/private/class-c-old.rkt
@@ -3,6 +3,7 @@
                      racket/stxparam
                      syntax/parse)
          racket/stxparam
+         "class-wrapped.rkt"
          "class-internal.rkt"
          "../contract/base.rkt"
          "../contract/combinator.rkt"
@@ -16,7 +17,8 @@
          (for-syntax parse-class/c-specs)
          (struct-out internal-class/c)
          just-check-existence just-check-existence?
-         build-internal-class/c internal-class/c-proj)
+         build-internal-class/c internal-class/c-proj
+         class/c-internal-name-clauses)
 
 (define undefined (letrec ([x x]) x))
 
@@ -35,7 +37,7 @@
   (syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx)))
 
 (define (class/c-check-first-order ctc cls fail)
-  (unless (-class? cls)  ;; TODO: might be a wrapper class
+  (unless (class? cls)
     (fail '(expected: "a class" given: "~v") cls))
   (define method-ht (class-method-ht cls))
   (define methods (class-methods cls))
@@ -180,13 +182,6 @@
             (list init #f))))
     
     (λ (cls)
-      ;; TODO: hack! this drops the new-style contract
-      ;; from classes that are going thru the old-style contract
-      (let loop ([a-class cls])
-        (cond
-          [(wrapped-class? a-class) 
-           (loop (wrapped-class-info-class (wrapped-class-the-info a-class)))]
-          [else (set! cls a-class)]))
       (class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args)))
       (let* ([name (class-name cls)]
              [never-wrapped? (eq? (class-orig-cls cls) cls)]
@@ -759,6 +754,66 @@
       [(just-check-existence? obj) #f]
       [else (coerce-contract 'class/c obj)])))
 
+(define (build-class/c-name ctc)
+  (or (build-class/c-name ctc)
+      (let* ([handled-methods
+              (for/list ([i (in-list (class/c-methods ctc))]
+                         [ctc (in-list (class/c-method-contracts ctc))])
+                (cond
+                  [ctc (build-compound-type-name i ctc)]
+                  [else i]))])
+        (apply build-compound-type-name
+               'class/c 
+               (append
+                handled-methods
+                (handle-optional 'init (class/c-inits ctc) (class/c-init-contracts ctc))
+                (handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc))
+                (class/c-internal-name-clauses (class/c-internal ctc))
+                (handle-absents (class/c-absents ctc) (class/c-absent-fields ctc)))))))
+
+(define (class/c-internal-name-clauses internal-ctc)
+  (append
+   (handle-optional 'inherit 
+                    (internal-class/c-inherits internal-ctc)
+                    (internal-class/c-inherit-contracts internal-ctc))
+   (handle-optional 'inherit-field 
+                    (internal-class/c-inherit-fields internal-ctc)
+                    (internal-class/c-inherit-field-contracts internal-ctc))
+   (handle-optional 'super
+                    (internal-class/c-supers internal-ctc)
+                    (internal-class/c-super-contracts internal-ctc))
+   (handle-optional 'inner 
+                    (internal-class/c-inners internal-ctc) 
+                    (internal-class/c-inner-contracts internal-ctc))
+   (handle-optional 'override
+                    (internal-class/c-overrides internal-ctc)
+                    (internal-class/c-override-contracts internal-ctc))
+   (handle-optional 'augment
+                    (internal-class/c-augments internal-ctc)
+                    (internal-class/c-augment-contracts internal-ctc))
+   (handle-optional 'augride
+                    (internal-class/c-augrides internal-ctc)
+                    (internal-class/c-augride-contracts internal-ctc))))
+
+(define (pair-ids-ctcs is ctcs)
+  (for/list ([i (in-list is)]
+             [ctc (in-list ctcs)])
+    (if (not ctc)
+        i
+        (build-compound-type-name i ctc))))
+(define (handle-optional name is ctcs)
+  (if (null? is)
+      null
+      (list (cons name (pair-ids-ctcs is ctcs)))))
+(define (handle-absents meths fields)
+  (cond
+    [(and (null? meths) (null? fields))
+     null]
+    [(null? fields)
+     (list (cons 'absent meths))]
+    [else
+     (list (list* 'absent (cons 'field fields) meths))]))
+             
 (define-struct class/c 
   (methods method-contracts fields field-contracts inits init-contracts
    absents absent-fields 
@@ -767,64 +822,7 @@
   #:property prop:contract
   (build-contract-property
    #:projection class/c-proj
-   #:name 
-   (λ (ctc)
-     (or (class/c-name ctc)
-         (let* ([pair-ids-ctcs
-                 (λ (is ctcs)
-                   (for/list ([i (in-list is)]
-                              [ctc (in-list ctcs)])
-                     (if (not ctc)
-                         i
-                         (build-compound-type-name i ctc))))]
-                [handle-optional
-                 (λ (name is ctcs)
-                   (if (null? is)
-                       null
-                       (list (cons name (pair-ids-ctcs is ctcs)))))]
-                [handle-absents
-                 (λ (meths fields)
-                   (cond
-                     [(and (null? meths) (null? fields))
-                      null]
-                     [(null? fields)
-                      (list (cons 'absent meths))]
-                     [else
-                      (list (list* 'absent (cons 'field fields) meths))]))]
-                [handled-methods
-                 (for/list ([i (in-list (class/c-methods ctc))]
-                            [ctc (in-list (class/c-method-contracts ctc))])
-                   (cond
-                     [ctc (build-compound-type-name i ctc)]
-                     [else i]))])
-           (apply build-compound-type-name
-                  'class/c 
-                  (append
-                   handled-methods
-                   (handle-optional 'init (class/c-inits ctc) (class/c-init-contracts ctc))
-                   (handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc))
-                   (handle-optional 'inherit 
-                                    (internal-class/c-inherits (class/c-internal ctc))
-                                    (internal-class/c-inherit-contracts (class/c-internal ctc)))
-                   (handle-optional 'inherit-field 
-                                    (internal-class/c-inherit-fields (class/c-internal ctc))
-                                    (internal-class/c-inherit-field-contracts (class/c-internal ctc)))
-                   (handle-optional 'super
-                                    (internal-class/c-supers (class/c-internal ctc))
-                                    (internal-class/c-super-contracts (class/c-internal ctc)))
-                   (handle-optional 'inner 
-                                    (internal-class/c-inners (class/c-internal ctc)) 
-                                    (internal-class/c-inner-contracts (class/c-internal ctc)))
-                   (handle-optional 'override
-                                    (internal-class/c-overrides (class/c-internal ctc))
-                                    (internal-class/c-override-contracts (class/c-internal ctc)))
-                   (handle-optional 'augment
-                                    (internal-class/c-augments (class/c-internal ctc))
-                                    (internal-class/c-augment-contracts (class/c-internal ctc)))
-                   (handle-optional 'augride
-                                    (internal-class/c-augrides (class/c-internal ctc))
-                                    (internal-class/c-augride-contracts (class/c-internal ctc)))
-                   (handle-absents (class/c-absents ctc) (class/c-absent-fields ctc)))))))
+   #:name build-class/c-name
    #:first-order
    (λ (ctc)
      (λ (cls)
@@ -1163,14 +1161,15 @@
       (define original-obj (if (has-original-object? val) (original-object val) val))
       (define new-cls (p (object-ref val)))
       (cond
-        [(wrapped-class? new-cls)
-         (define the-info (wrapped-class-the-info new-cls))
+        [(impersonator-prop:has-wrapped-class-neg-party? new-cls)
+         (define the-info (impersonator-prop:get-wrapped-class-info new-cls))
+         (define neg-party (impersonator-prop:get-wrapped-class-neg-party new-cls))
          (wrapped-object
           val
           (wrapped-class-info-neg-extra-arg-vec the-info)
           (wrapped-class-info-pos-field-projs the-info)
           (wrapped-class-info-neg-field-projs the-info)
-          (wrapped-class-neg-party new-cls))]
+          neg-party)]
         [else
          (impersonate-struct val object-ref (λ (o c) new-cls)
                              impersonator-prop:contracted ctc
diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt
index be96ecc085..66ce031f17 100644
--- a/racket/collects/racket/private/class-internal.rkt
+++ b/racket/collects/racket/private/class-internal.rkt
@@ -2031,15 +2031,10 @@ last few projections.
 
 |#
 
-(define -class?
-  (let ([class?
-         (λ (x) (or (class? x) (wrapped-class? x)))])
-    class?))
-
 ;; compose-class: produces one result if `deserialize-id' is #f, two
 ;;                results if `deserialize-id' is not #f
 (define (compose-class name                ; symbol
-                       raw-super           ; class, possibly wrapper-class
+                       super               ; class, possibly with contract impersonator properties
                        interfaces          ; list of interfaces
                        inspector           ; inspector or #f
                        deserialize-id      ; identifier or #f
@@ -2076,10 +2071,9 @@ last few projections.
               meth-name
               (if name " in " "")
               (or name "")))))
-  (define super (unwrap-class raw-super))
   
   ;; -- Check superclass --
-  (unless (-class? super)
+  (unless (class? super)
     (obj-error 'class* "superclass expression result is not a class"
                "result" super
                #:class-name name))
@@ -2318,23 +2312,23 @@ last few projections.
             ;; --- Make the new external method contract records ---
             ;; (they are just copies of the super at this point, updated below)
             (define wci-neg-extra-arg-vec 
-              (if (class? raw-super)
-                  #f
-                  (let* ([the-info (wrapped-class-the-info raw-super)]
+              (if (impersonator-prop:has-wrapped-class-neg-party? super)
+                  (let* ([the-info (impersonator-prop:get-wrapped-class-info super)]
                          [ov (wrapped-class-info-neg-extra-arg-vec the-info)])
                     (if no-method-changes?
                         ov
                         (let ([v (make-vector method-width #f)])
                           (vector-copy! v 0 ov)
-                          v)))))
+                          v)))
+                  #f))
             (define wci-neg-acceptors-ht
-              (if (class? raw-super)
-                  #f
-                  (let* ([the-info (wrapped-class-the-info raw-super)]
+              (if (impersonator-prop:has-wrapped-class-neg-party? super)
+                  (let* ([the-info (impersonator-prop:get-wrapped-class-info super)]
                          [oh (wrapped-class-info-neg-acceptors-ht the-info)])
                     (if no-method-changes?
                         oh
-                        (hash-copy oh)))))
+                        (hash-copy oh)))
+                  #f))
             
             ;; --- Make the new object struct ---
             (let*-values ([(prim-object-make prim-object? struct:prim-object)
@@ -2641,22 +2635,63 @@ last few projections.
                                    (loop (add1 i))))))))
                       
                       ;; --- Install initializer into class ---
-                      (set-class-init! c init)
-                      
+                      ;;     and create contract-wrapped subclass
                       (define c+ctc
-                        (if wci-neg-extra-arg-vec
-                            (let ([info (wrapped-class-the-info raw-super)])
-                              (wrapped-class
-                               (wrapped-class-info 
-                                c
-                                (wrapped-class-info-blame info)
-                                wci-neg-extra-arg-vec
-                                wci-neg-acceptors-ht
-                                (wrapped-class-info-pos-field-projs info)
-                                (wrapped-class-info-neg-field-projs info)
-                                (wrapped-class-info-init-proj-pairs info))
-                               (wrapped-class-neg-party raw-super)))
-                            c))
+                        (cond
+                          [wci-neg-extra-arg-vec
+                           (define neg-party (impersonator-prop:get-wrapped-class-neg-party super))
+                           (define info (impersonator-prop:get-wrapped-class-info super))
+                           (define blame (wrapped-class-info-blame info))
+                           (define sub-init-proj-pairs
+                             (let loop ([proj-pairs (wrapped-class-info-init-proj-pairs info)])
+                               (cond
+                                 [(null? proj-pairs) '()]
+                                 [else
+                                  (define pr (car proj-pairs))
+                                  (if (member (list-ref pr 0) init-args)
+                                      (loop (cdr proj-pairs))
+                                      (cons pr (loop (cdr proj-pairs))))])))
+                           (define super-init-proj-pairs (wrapped-class-info-init-proj-pairs info))
+                           
+                           ;; use an init that checks the super contracts on a super call
+                           (set-class-init!
+                            c
+                            (λ (o continue-make-super c inited? leftovers named-args)
+                              (define (contract-checking-continue-make-super o c inited?
+                                                                             leftovers
+                                                                             by-pos-args
+                                                                             new-named-args)
+                                (check-arg-contracts blame neg-party c
+                                                     super-init-proj-pairs
+                                                     new-named-args)
+                                (continue-make-super o c inited?
+                                                     leftovers
+                                                     by-pos-args
+                                                     new-named-args))
+                              (init o contract-checking-continue-make-super
+                                    c inited? leftovers named-args)))
+                           
+                           ;; add properties to the subclass that
+                           ;; check the residual external contracts
+                           (impersonate-struct
+                            c
+                            
+                            set-class-orig-cls! (λ (a b) b)
+                            
+                            impersonator-prop:wrapped-class-neg-party
+                            neg-party
+                            
+                            impersonator-prop:wrapped-class-info
+                            (wrapped-class-info 
+                             blame
+                             wci-neg-extra-arg-vec
+                             wci-neg-acceptors-ht
+                             (wrapped-class-info-pos-field-projs info)
+                             (wrapped-class-info-neg-field-projs info)
+                             sub-init-proj-pairs))]
+                          [else
+                           (set-class-init! c init)
+                           c]))
                       
                       ;; -- result is the class, and maybe deserialize-info ---
                       (if deserialize-id
@@ -2812,7 +2847,8 @@ An example
                       (make-struct-type 'props struct-type 0 0 #f props #f)])
           struct:))))
 
-(define-values (prop:object _object? object-ref) (make-struct-type-property 'object 'can-impersonate))
+(define-values (prop:object _object? object-ref) 
+  (make-struct-type-property 'object 'can-impersonate))
 (define (object? o)
   (or (_object? o)
       (wrapped-object? o)))
@@ -2825,6 +2861,7 @@ An example
      (object-ref o)]))
 
 
+
 ;;--------------------------------------------------------------------
 ;;  interfaces
 ;;--------------------------------------------------------------------
@@ -3269,22 +3306,22 @@ An example
 
 (define (do-make-object blame class by-pos-args named-args)
   (cond
-    [(class? class)
-     (do-make-object/real-class blame class by-pos-args named-args #f #f '())]
-    [(wrapped-class? class)
-     (define the-info (wrapped-class-the-info class))
-     (define unwrapped-class (wrapped-class-info-class the-info))
+    [(impersonator-prop:has-wrapped-class-neg-party? class)
+     (define the-info (impersonator-prop:get-wrapped-class-info class))
+     (define neg-party (impersonator-prop:get-wrapped-class-neg-party class))
      (define unwrapped-o 
-       (do-make-object/real-class blame unwrapped-class by-pos-args named-args
+       (do-make-object/real-class blame class by-pos-args named-args
                                   (wrapped-class-info-blame the-info)
-                                  (wrapped-class-neg-party class)
+                                  neg-party
                                   (wrapped-class-info-init-proj-pairs the-info)))
      (wrapped-object
       unwrapped-o
       (wrapped-class-info-neg-extra-arg-vec the-info)
       (wrapped-class-info-pos-field-projs the-info)
       (wrapped-class-info-neg-field-projs the-info)
-      (wrapped-class-neg-party class))]
+      neg-party)]
+    [(class? class)
+     (do-make-object/real-class blame class by-pos-args named-args #f #f '())]
     [else
      (raise-argument-error 'instantiate "class?" class)]))
 
@@ -3645,41 +3682,69 @@ An example
              #:class-name (class-name cls)))
 
 (define-values (make-class-field-accessor make-class-field-mutator)
-  (let ([check-and-get-index
-         (λ (who class name)
-           (unless (-class? class)
-             (raise-argument-error who "class?" class))
-           (unless (symbol? name)
-             (raise-argument-error who "symbol?" name))
-           (hash-ref (class-field-ht (unwrap-class class)) name
-                     (lambda ()
-                       (obj-error who "no such field"
-                                  "field-name" (as-write name)
-                                  #:class-name (class-name (unwrap-class class))))))])
+  (let ()
+    (define (check-and-get-proc who class name get?)
+      (unless (class? class)
+        (raise-argument-error who "class?" class))
+      (unless (symbol? name)
+        (raise-argument-error who "symbol?" name))
+      (define field-info-external-X (if get? field-info-external-ref field-info-external-set!))
+      (define wrapped-class-info-X-field-projs
+        (if get? 
+            wrapped-class-info-pos-field-projs
+            wrapped-class-info-neg-field-projs))
+      (define (get-accessor)
+        (field-info-external-X
+         (hash-ref (class-field-ht class) name
+                   (lambda ()
+                     (obj-error who "no such field"
+                                "field-name" (as-write name)
+                                #:class-name (class-name class))))))
+      (cond
+        [(impersonator-prop:has-wrapped-class-neg-party? class)
+         (define the-info (impersonator-prop:get-wrapped-class-info class))
+         (define projs (hash-ref (wrapped-class-info-X-field-projs the-info) name #f))
+         (define np (impersonator-prop:get-wrapped-class-neg-party class))
+         (cond
+           [projs 
+            (if get?
+                (let loop ([projs projs])
+                  (cond
+                    [(pair? projs)
+                     (define f-rest (loop (cdr projs)))
+                     (define f-this (car projs))
+                     (λ (val) ((f-this (f-rest val)) np))]
+                    [else projs]))
+                (let loop ([projs projs])
+                  (cond
+                    [(pair? projs)
+                     (define f-rest (loop (cdr projs)))
+                     (define f-this (car projs))
+                     (λ (o val) ((f-this (f-rest o val)) np))]
+                    [else projs])))]
+           [else (get-accessor)])]
+        [else
+         (get-accessor)]))
     (values (λ (class name)
-              (let* ([fi (check-and-get-index 'class-field-accessor class name)]
-                     [ref (field-info-external-ref fi)])
-                (λ (o) 
-                  (cond
-                    [(_object? o)
-                     (ref o)]
-                    [else
-                     (define uw (unwrap-object o))
-                     (if (_object? uw)
-                         (ref uw)
-                         (raise-argument-error 'class-field-accessor "object?" o))]))))
+              (define ref (check-and-get-proc 'class-field-accessor class name #t))
+              (λ (o)
+                (cond
+                  [(_object? o)
+                   (ref o)]
+                  [(wrapped-object? o)
+                   (ref (wrapped-object-object o))]
+                  [else
+                   (raise-argument-error 'class-field-accessor "object?" o)])))
             (λ (class name)
-              (let* ([fi (check-and-get-index 'class-field-mutator class name)]
-                     [setter! (field-info-external-set! fi)])
-                (λ (o v) 
-                  (cond
-                    [(_object? o)
-                     (setter! o v)]
-                    [else
-                     (define uw (unwrap-object o))
-                     (if (_object? uw)
-                         (setter! uw v)
-                         (raise-argument-error 'class-field-mutator "object?" o))])))))))
+              (define setter! (check-and-get-proc 'class-field-mutator class name #f))
+              (λ (o v) 
+                (cond
+                  [(_object? o)
+                   (setter! o v)]
+                  [(wrapped-object? o)
+                   (setter! (unwrap-object o) v)]
+                  [else
+                   (raise-argument-error 'class-field-mutator "object?" o)]))))))
 
 (define-struct generic (name applicable))
 
@@ -3689,7 +3754,7 @@ An example
 (define make-generic/proc
   (let ([make-generic
          (lambda (class name)
-           (unless (or (-class? class) (interface? class))
+           (unless (or (class? class) (interface? class))
              (raise-argument-error 'make-generic "(or/c class? interface?)" class))
            (unless (symbol? name)
              (raise-argument-error 'make-generic "symbol?" name))
@@ -3709,8 +3774,7 @@ An example
                        "target" obj
                        #:intf-name (interface-name intf)))
                     (find-method/who 'make-generic obj name)))
-                (let* ([class (unwrap-class class)]  ;; TODO: should this do checking?
-                       [pos (hash-ref (class-method-ht class) name
+                (let* ([pos (hash-ref (class-method-ht class) name
                                       (lambda ()
                                         (obj-error 'make-generic "no such method"
                                                    "method name" (as-write name)
@@ -4003,17 +4067,17 @@ An example
 
 (define (is-a? v c)
   (cond
-    [(-class? c) 
-     (and (object? v) ((class-object? (class-orig-cls (unwrap-class c))) (unwrap-object v)))]
+    [(class? c) 
+     (and (object? v) ((class-object? (class-orig-cls c)) (unwrap-object v)))]
     [(interface? c) (and (object? v) (implementation? (object-ref/unwrap v) c))]
     [else (raise-argument-error 'is-a? "(or/c class? interface?)" 1 v c)]))
 
 (define (subclass? v c)
-  (unless (-class? c)
+  (unless (class? c)
     (raise-argument-error 'subclass? "class?" 1 v c))
-  (and (-class? v)
-       (let* ([c (class-orig-cls (unwrap-class c))]
-              [v (class-orig-cls (unwrap-class v))]
+  (and (class? v)
+       (let* ([c (class-orig-cls c)]
+              [v (class-orig-cls v)]
               [p (class-pos c)])
          (and (<= p (class-pos v))
               (eq? c (vector-ref (class-supers v) p))))))
@@ -4042,8 +4106,8 @@ An example
 (define (implementation? v i)
   (unless (interface? i)
     (raise-argument-error 'implementation? "interface?" 1 v i))
-  (and (-class? v)
-       (interface-extension? (class-self-interface (unwrap-class v)) i)))
+  (and (class? v)
+       (interface-extension? (class-self-interface v) i)))
 
 (define (interface-extension? v i)
   (unless (interface? i)
@@ -4059,9 +4123,9 @@ An example
   (and (memq s (interface-public-ids i)) #t))
 
 (define (class->interface c)
-  (unless (-class? c)
+  (unless (class? c)
     (raise-argument-error 'class->interface "class?" c))
-  (class-self-interface (unwrap-class c)))
+  (class-self-interface c))
 
 (define (interned? sym)
   (eq? sym (string->symbol (symbol->string sym))))
@@ -4090,10 +4154,9 @@ An example
       (string->symbol s)
       s))
 
-(define (class-info _c)
-  (unless (-class? _c)
-    (raise-argument-error 'class-info "class?" _c))
-  (define c (unwrap-class _c))
+(define (class-info c)
+  (unless (class? c)
+    (raise-argument-error 'class-info "class?" c))
   (if (struct? ((class-insp-mk c)))
       (let ([super (vector-ref (class-supers c) (sub1 (class-pos c)))])
         (let loop ([next super][skipped? #f])
@@ -4143,9 +4206,15 @@ An example
     (raise-argument-error 'object=? "object?" o1))
   (unless (object? o2)
     (raise-argument-error 'object=? "object?" o2))
-  (let ([orig-o1 (if (has-original-object? o1) (original-object o1) o1)]
-        [orig-o2 (if (has-original-object? o2) (original-object o2) o2)])
-    (eq? orig-o1 orig-o2)))
+  (let* ([orig-o1 (if (has-original-object? o1) (original-object o1) o1)]
+         [orig-o2 (if (has-original-object? o2) (original-object o2) o2)]
+         [orig-orig-o1 (if (wrapped-object? orig-o1)
+                           (wrapped-object-object orig-o1)
+                           orig-o1)]
+         [orig-orig-o2 (if (wrapped-object? orig-o2)
+                           (wrapped-object-object orig-o2)
+                           orig-o2)])
+    (eq? orig-orig-o1 orig-orig-o2)))
 
 ;;--------------------------------------------------------------------
 ;;  primitive classes
@@ -4380,7 +4449,7 @@ An example
 
 (define (check-mixin-super mixin-name super% from-ids)
   (let ([mixin-name (or mixin-name 'mixin)])
-    (unless (-class? super%)
+    (unless (class? super%)
       (obj-error mixin-name 
                  "argument is not a class"
                  "argument" super%))
@@ -4530,7 +4599,7 @@ An example
 (provide (protect-out get-field/proc)
          
          ;; for class-c-old.rkt:
-         -class? make-naming-constructor prop:object _object? object-ref replace-ictc-blame
+         make-naming-constructor prop:object _object? object-ref replace-ictc-blame
          concretize-ictc-method field-info-extend-external field-info-extend-internal this-param
          object-ref/unwrap impersonator-prop:original-object has-original-object? original-object
          ;; end class-c-old.rkt requirements
@@ -4540,7 +4609,7 @@ An example
          
          (rename-out [_class class]) class* class/derived
          define-serializable-class define-serializable-class*
-         (rename-out [-class? class?])
+         class?
          mixin
          (rename-out [_interface interface]) interface* interface?
          object% object? object=? externalizable<%> printable<%> writable<%> equal<%>
@@ -4569,4 +4638,4 @@ An example
          (for-syntax localize) 
          (except-out (struct-out class) class class?)
          (rename-out [class? class-struct-predicate?])
-         (struct-out wrapped-class) (struct-out wrapped-class-info) (struct-out wrapped-object))
+         (struct-out wrapped-object))
diff --git a/racket/collects/racket/private/class-wrapped.rkt b/racket/collects/racket/private/class-wrapped.rkt
index d998a370a5..03364d3d34 100644
--- a/racket/collects/racket/private/class-wrapped.rkt
+++ b/racket/collects/racket/private/class-wrapped.rkt
@@ -1,20 +1,21 @@
 #lang racket/base
-(provide (struct-out wrapped-class-info)
-         (struct-out wrapped-class)
+(provide (except-out (struct-out wrapped-class-info) wrapped-class-info?)
          (struct-out wrapped-object)
-         unwrap-class
-         unwrap-object)
+         unwrap-object
+         
+         impersonator-prop:wrapped-class-info 
+         impersonator-prop:has-wrapped-class-info?
+         impersonator-prop:get-wrapped-class-info
 
-(struct wrapped-class-info (class blame 
-                             neg-extra-arg-vec ;; vector that parallels the class's vector of methods
-                             neg-acceptors-ht ;; range of ht has curried (neg-pary -> mth) fns
-                             pos-field-projs neg-field-projs
-                             init-proj-pairs)
-  #:transparent)
-(struct wrapped-class (the-info neg-party)
-  #:property prop:custom-write
-  (λ (stct port mode)
-    (do-custom-write (wrapped-class-info-class (wrapped-class-the-info stct)) port mode))
+         impersonator-prop:wrapped-class-neg-party
+         impersonator-prop:has-wrapped-class-neg-party?
+         impersonator-prop:get-wrapped-class-neg-party)
+
+(struct wrapped-class-info (blame 
+                            neg-extra-arg-vec ;; vector that parallels the class's vector of methods
+                            neg-acceptors-ht ;; range of ht has curried (neg-pary -> mth) fns
+                            pos-field-projs neg-field-projs
+                            init-proj-pairs)
   #:transparent)
 
 (struct wrapped-object (object neg-extra-arg-vec pos-field-projs neg-field-projs neg-party)
@@ -34,13 +35,17 @@
     [else
      (print v port mode)]))
 
-
 (define (unwrap-object o)
   (cond
     [(wrapped-object? o) (wrapped-object-object o)]
     [else o]))
 
-(define (unwrap-class cls)
-  (cond
-    [(wrapped-class? cls) (wrapped-class-info-class (wrapped-class-the-info cls))]
-    [else cls]))
+(define-values (impersonator-prop:wrapped-class-info 
+                impersonator-prop:has-wrapped-class-info?
+                impersonator-prop:get-wrapped-class-info)
+  (make-impersonator-property 'wrapped-class-info))
+
+(define-values (impersonator-prop:wrapped-class-neg-party
+                impersonator-prop:has-wrapped-class-neg-party?
+                impersonator-prop:get-wrapped-class-neg-party)
+  (make-impersonator-property 'wrapped-class-neg-party))