From c2fcdbba650ee4f3ac93c1b28df58348b30a1a0b Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 22 Feb 2010 19:09:42 +0000
Subject: [PATCH 01/26] Class Contracts Phase 2: Object/c Boogaloo

This isn't just a copy of trunk r18264 -- it has a slight difference in how
local field accessors and mutators are handled that will eventually play a
larger role.

svn: r18265
---
 collects/scheme/private/class-internal.ss | 23 ++++++++++++-----------
 1 file changed, 12 insertions(+), 11 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 2784d61608..61ce180564 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -1329,17 +1329,13 @@
                                    ;; Methods (when given needed super-methods, etc.):
                                    #, ;; Attach srcloc (useful for profiling)
                                    (quasisyntax/loc stx
-                                     (lambda (local-accessor
-                                              local-mutator
+                                     (lambda (local-field-accessor ...
+                                              local-field-mutator ...
                                               inherit-field-accessor ...  ; inherit
                                               inherit-field-mutator ...
                                               rename-super-temp ... rename-super-extra-temp ...
                                               rename-inner-temp ... rename-inner-extra-temp ...
                                               method-accessor ...) ; for a local call that needs a dynamic lookup
-                                       (let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)]
-                                             ...
-                                             [local-field-mutator (make-struct-field-mutator local-mutator local-field-pos #f)]
-                                             ...)
                                          (syntax-parameterize
                                           ([this-param (make-this-map (quote-syntax this-id)
                                                                       (quote-syntax the-finder)
@@ -1461,7 +1457,7 @@
                                                                                (quote-syntax plain-init-name-localized))] ...)
                                                         ([(local-plain-init-name) undefined] ...)
                                                         (void) ; in case the body is empty
-                                                        . exprs)))))))))))))
+                                                        . exprs))))))))))))
                                    ;; Not primitive:
                                    #f))))))))))))))))
     
@@ -2160,7 +2156,12 @@
               
               ;; --- Build field accessors and mutators ---
               ;;  Use public field names to name the accessors and mutators
-              (let-values ([(inh-accessors inh-mutators)
+              (let-values ([(local-accessors local-mutators)
+                            (values (for/list ([n (in-range num-fields)]) 
+                                      (make-struct-field-accessor object-field-ref n #f))
+                                    (for/list ([n (in-range num-fields)]) 
+                                      (make-struct-field-mutator object-field-set! n #f)))]
+                           [(inh-accessors inh-mutators)
                             (values (map (lambda (id) (vector-ref int-field-refs (hash-ref field-ht id)))
                                          inherit-field-names)
                                     (map (lambda (id) (vector-ref int-field-sets (hash-ref field-ht id)))
@@ -2260,9 +2261,9 @@
                     ;; -- Get new methods and initializers --
                     (let-values ([(new-methods override-methods augride-methods init)
                                   (apply make-methods
-                                         object-field-ref
-                                         object-field-set!
-                                         (append inh-accessors
+                                         (append local-accessors
+                                                 local-mutators
+                                                 inh-accessors
                                                  inh-mutators
                                                  rename-supers
                                                  rename-inners

From d820493febe1bac09b4736c314232fb641860853 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 22 Feb 2010 21:55:32 +0000
Subject: [PATCH 02/26] First cut of converting object-contract to share a
 common base that object/c will also use.

svn: r18274
---
 collects/scheme/contract/private/object.ss |  77 +----
 collects/scheme/private/class-internal.ss  | 321 +++++++++------------
 collects/tests/mzscheme/contract-test.ss   |  30 +-
 3 files changed, 170 insertions(+), 258 deletions(-)

diff --git a/collects/scheme/contract/private/object.ss b/collects/scheme/contract/private/object.ss
index cfb13a9319..ea9750098b 100644
--- a/collects/scheme/contract/private/object.ss
+++ b/collects/scheme/contract/private/object.ss
@@ -13,27 +13,6 @@
          implementation?/c
          object-contract)
 
-;; example of how one contract is constructed
-#;
-(let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))]
-       [cf (-> integer? integer?)]
-       [m-proj ((contract-projection cm)
-                (make-blame #'here #f "whatever" 'pos 'neg #t))]
-       [f-proj ((contract-projection cf)
-                (make-blame #'here #f "whatever" 'pos 'neg #t))]
-       [cls (make-wrapper-class 'wrapper-class
-                                '(m)
-                                (list 
-                                 (m-proj (λ (this x) (send (wrapper-object-wrapped this) m x))))
-                                '(f)
-                                #f)]
-       [o (new (class object%
-                 (field [f (λ (x) x)])
-                 (define/public (m x) x)
-                 (super-new)))]
-       [wo (make-object cls o (f-proj (get-field/proc 'f o)))])
-  ((get-field/proc 'f wo) #f))
-
 (define-for-syntax (parse-object-contract stx args)
   (let loop ([args (syntax->list args)]
              [mtds '()]
@@ -52,55 +31,17 @@
               [_ 
                (raise-syntax-error #f "malformed object-contract clause" stx (car args))])])))
 
-(define (o-c-first-order ctc val blame meth-projs)
-  (let/ec return
-    (define (failed str . args)
-      (if blame
-          (apply raise-blame-error blame val str args)
-          (return #f)))
-    (unless (object? val)
-      (failed "expected an object, got ~e" val))
-    (let ([meth-names (object-contract-methods ctc)])
-      (for-each (λ (m proj)
-                  (let-values ([(method unwrapper) 
-                                (find-method/who 'object-contract val m #:error? #f)])
-                    (unless method
-                      (failed "expected an object with method ~s" m))
-                    ;; verify the first-order properties by apply the projection and 
-                    ;; throwing the result away. Without this, the contract wrappers
-                    ;; just check the first-order properties of the wrappers, which is
-                    ;; the wrong thing.
-                    (proj method)))
-                meth-names
-                meth-projs))
-    (let ([ctc-field-names (object-contract-fields ctc)]
-          [fields (field-names val)])
-      (for-each (λ (f)
-                  (unless (memq f fields)
-                    (failed "expected an object with field ~s" f)))
-                ctc-field-names))
-    #t))
-
-(define-struct object-contract (methods method-ctcs method-wrappers fields field-ctcs)
+(define-struct object-contract (methods method-ctcs fields field-ctcs)
   #:omit-define-syntaxes
   #:property prop:contract
   (build-contract-property
    #:projection
    (λ (ctc)
-      (let ([meth-names (object-contract-methods ctc)]
-            [meth-param-projs (map contract-projection (object-contract-method-ctcs ctc))]
-            [ctc-field-names (object-contract-fields ctc)]
-            [field-param-projs (map contract-projection (object-contract-field-ctcs ctc))])
-        (λ (blame)
-           (let* ([meth-projs (map (λ (x) (x blame)) meth-param-projs)]
-                  [meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))]
-                  [cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)]
-                  [field-projs (map (λ (x) (x blame)) field-param-projs)])
-             (λ (val)
-                (o-c-first-order ctc val blame meth-projs)
-                (apply make-object cls val
-                       (map (λ (field proj) (proj (get-field/proc field val)))
-                            ctc-field-names field-projs)))))))
+     (λ (blame)
+       (λ (val)
+         (make-wrapper-object val blame
+                              (object-contract-methods ctc) (object-contract-method-ctcs ctc)
+                              (object-contract-fields ctc) (object-contract-field-ctcs ctc)))))
    #:name
    (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
                                      (object-contract-fields ctc)
@@ -112,7 +53,7 @@
    #:first-order 
    (λ (ctc)
      (λ (val)
-       (o-c-first-order ctc val #f (map (λ (x) values) (object-contract-method-ctcs ctc)))))))
+       (check-object-contract val #f (object-contract-methods ctc) (object-contract-fields ctc))))))
 
 (define-syntax (object-contract stx)
   (syntax-case stx ()
@@ -124,14 +65,12 @@
                                              (syntax->list #'(method-id ...)))])
          #'(build-object-contract '(method-id ...)
                                   (syntax-parameterize ((making-a-method #t)) (list (let ([method-name method-ctc]) method-name) ...))
-                                  (list (λ (this . x) (send (wrapper-object-wrapped this) method-id . x)) ...)
                                   '(field-id ...)
                                   (list field-ctc ...))))]))
 
-(define (build-object-contract methods method-ctcs wrappers fields field-ctcs)
+(define (build-object-contract methods method-ctcs fields field-ctcs)
   (make-object-contract methods 
                         (map (λ (x) (coerce-contract 'object-contract x)) method-ctcs)
-                        wrappers 
                         fields 
                         (map (λ (x) (coerce-contract 'object-contract x)) field-ctcs)))
 
diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index cf6b54fe05..69f16afef4 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -2994,7 +2994,7 @@
                          augments augment-ctcs
                          augrides augride-ctcs))))]))
 
-(define (object/c-check-first-order ctc obj blame)
+(define (check-object-contract obj blame methods fields)
   (let/ec return
     (define (failed str . args)
       (if blame
@@ -3004,19 +3004,24 @@
       (failed "not a object"))
     (let ([cls (object-ref obj)])
       (let ([method-ht (class-method-ht cls)])
-        (for ([m (object/c-methods ctc)])
+        (for ([m methods])
           (unless (hash-ref method-ht m #f)
             (failed "no public method ~a" m))))
       (let ([field-ht (class-field-ht cls)])
-        (for ([m (object/c-fields ctc)])
+        (for ([m fields])
           (unless (hash-ref field-ht m #f)
             (failed "no public field ~a" m)))))))
 
+(define (object/c-check-first-order ctc obj blame)
+  (check-object-contract obj blame (object/c-methods) (object/c-fields)))
+
 (define (object/c-proj ctc)
   (λ (blame)
     (λ (obj)
       (object/c-check-first-order ctc obj blame)
-      obj)))
+      (make-wrapper-object obj blame 
+                           (object/c-methods ctc) (object/c-method-contracts ctc)
+                           (object/c-fields ctc) (object/c-field-contracts ctc)))))
 
 (define-struct object/c (methods method-contracts fields field-contracts)
   #:omit-define-syntaxes
@@ -3835,8 +3840,6 @@
        (cond
          [index
           ((vector-ref (class-ext-field-sets cls) index) obj val)]
-         [(wrapper-object? obj)
-          (loop (wrapper-object-wrapped obj))]
          [else
           (raise-mismatch-error 
            'get-field
@@ -3876,8 +3879,6 @@
        (cond
          [index
           ((vector-ref (class-ext-field-refs cls) index) obj)]
-         [(wrapper-object? obj)
-          (loop (wrapper-object-wrapped obj))]
          [else
           (raise-mismatch-error 
            'get-field
@@ -3913,10 +3914,8 @@
    (let loop ([obj obj])
      (let* ([cls (object-ref obj)]
             [field-ht (class-field-ht cls)])
-       (or (and (hash-ref field-ht id #f)
-                #t) ;; ensure that only #t and #f leak out, not bindings in ht
-           (and (wrapper-object? obj)
-                (loop (wrapper-object-wrapped obj))))))))
+       (and (hash-ref field-ht id #f)
+            #t))))) ;; ensure that only #t and #f leak out, not bindings in ht
 
 (define-traced (field-names obj)
   (unless (object? obj)
@@ -3930,9 +3929,7 @@
      (let* ([cls (object-ref obj)]
             [field-ht (class-field-ht cls)]
             [flds (filter interned? (hash-map field-ht (lambda (x y) x)))])
-       (if (wrapper-object? obj)
-           (append flds (loop (wrapper-object-wrapped obj)))
-           flds)))))
+       flds))))
 
 (define-syntaxes (with-method with-method-traced)
   (let ()
@@ -4059,7 +4056,6 @@
        (cond
          [pos (procedure-arity-includes? (vector-ref (class-methods c) pos) 
                                          (add1 cnt))]
-         [(wrapper-object? o) (loop (wrapper-object-wrapped o))]
          [else #f])))))
 
 (define (implementation? v i)
@@ -4262,15 +4258,12 @@
 ;;  wrapper for contracts
 ;;--------------------------------------------------------------------
 
-(define-struct wrapper-field (name ctc-stx))
-(define-struct wrapper-method (name mth-stx))
-
 (define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
   (let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
                 (make-struct-type 'raw-wrapper-object
                                   #f
-                                  0
-                                  1)])
+                                  1
+                                  0)])
     (values wrapper-object?
             (lambda (v) (ref v 0))
             (lambda (o v) (set! o 0 v))
@@ -4283,161 +4276,137 @@
         (loop (wrapper-object-wrapped o))
         o)))
 
-;; make-wrapper-class :   symbol
-;;                        (listof symbol)
-;;                        method-spec [depends on the boolean what it is]
-;;                        (listof symbol)
-;;                        boolean
-;;                     -> class
-;; the resulting class is the "proxy" class for the contracted version of an
-;; object with contracts on the method-ids. 
-
-;; Overall, objects of this class have one field for the original object,
-;; one field per method in the contract and one field per field in the contract.
-;; Each of the methods (passed in) just accesses the initial (method) fields
-;; (which contain procedures) and calls them and returns their results.
-;; Those fields do not show up from outside of this file, via the usual
-;; field accessors. In addition, the class has one field per field that
-;; will contain the contracted versions of the input fields.
-;; The class accepts one initialization argument per method and
-;; one init arg per field (in that order) using the make-object style
-;; initialization.
-(define (make-wrapper-class class-name method-ids methods field-ids old-style?)
-  (let* ([supers (vector object% #f)]
-         [method-ht (make-hasheq)]
-         [method-count (length method-ids)]
-         [methods-vec (make-vector method-count #f)]
-         [int-methods-vec (make-vector method-count)]
-         [dynamic-idxs (make-vector method-count 0)]
-         [dynamic-projs (make-vector method-count (vector values))]
-         
-         [field-ht (make-hasheq)]
-         [field-count (length field-ids)]
-         [int-field-refs (make-vector field-count)]
-         [int-field-sets (make-vector field-count)]
-         [ext-field-refs (make-vector field-count)]
-         [ext-field-sets (make-vector field-count)]
-         
-         [cls
-          (make-class class-name
-                      1
-                      supers
-                      'bogus-self-interface
-                      void  ; nothing can be inspected
-                      
-                      method-count
-                      method-ht
-                      (reverse method-ids)
-                      
-                      methods-vec
-                      methods-vec
-                      int-methods-vec
-                      (list->vector (map (lambda (x) 'final) method-ids))
-                      'dont-use-me!
-                      (make-vector method-count values)
-                      dynamic-idxs
-                      dynamic-projs
-                      
-                      (if old-style?
-                          (+ field-count method-count 1)
-                          field-count)
-                      field-count
-                      field-ht
-                      field-ids
-                      
-                      int-field-refs
-                      int-field-sets
-                      ext-field-refs
-                      ext-field-sets
-                      
-                      #f; struct:object
-                      #f; object?
-                      #f; make-object ;; -> void
-                      #f; field-ref
-                      #f; field-set!
-                      
-                      #f ;; only by position arguments
-                      'normal ; init-mode - ??
-                      
-                      #f ; init
-                      #f ; orig-cls
-                      #f #f ; not serializable
-                      #f)])
-    (let-values ([(struct:object make-object object? field-ref field-set!)
-                  (make-struct-type 'wrapper-object
+(define (make-wrapper-class obj cls blame methods method-contracts fields field-contracts)
+  (let* ([name (class-name cls)]
+         [method-width (class-method-width cls)]
+         [method-ht (class-method-ht cls)]
+         [methods (if (null? methods)
+                      (class-methods cls)
+                      (make-vector method-width))]
+         [field-pub-width (class-field-pub-width cls)]
+         [field-ht (class-field-ht cls)]
+         [int-field-refs (make-vector field-pub-width)]
+         [int-field-sets (make-vector field-pub-width)]
+         [ext-field-refs (make-vector field-pub-width)]
+         [ext-field-sets (make-vector field-pub-width)]
+         [class-make (if name
+                         (make-naming-constructor 
+                          struct:class
+                          (string->symbol (format "class:~a" name)))
+                         make-class)]
+         [c (class-make name
+                        (class-pos cls)
+                        (list->vector (vector->list (class-supers cls)))
+                        (class-self-interface cls)
+                        void ;; No inspecting
+                        
+                        method-width
+                        method-ht
+                        (class-method-ids cls)
+                        
+                        methods
+                        (class-super-methods cls)
+                        (class-int-methods cls)
+                        (class-beta-methods cls)
+                        (class-meth-flags cls)
+                        
+                        (class-inner-projs cls)
+                        (class-dynamic-idxs cls)
+                        (class-dynamic-projs cls)
+                        
+                        (class-field-width cls)
+                        field-pub-width
+                        field-ht
+                        (class-field-ids cls)
+                        
+                        int-field-refs
+                        int-field-sets
+                        ext-field-refs
+                        ext-field-sets
+                        
+                        'struct:object 'object? 'make-object
+                        'field-ref 'field-set!
+                        
+                        (class-init-args cls)
+                        (class-init-mode cls)
+                        (class-init cls)
+                        
+                        (class-orig-cls cls)
+                        #f #f ; serializer is never set
+                        #f)]
+         [obj-name (if name
+                       (string->symbol (format "wrapper-object:~a" name))
+                       'object)])
+    
+    (vector-set! (class-supers c) (class-pos c) c)
+    
+    ;; --- Make the new object struct ---
+    (let-values ([(struct:object object-make object? object-field-ref object-field-set!)
+                  (make-struct-type obj-name
                                     struct:wrapper-object
-                                    0
-                                    (if old-style?
-                                        (+ (length field-ids) (length method-ids))
-                                        (length field-ids))
+                                    0 ;; No init fields
+                                    0 ;; No new fields in this wrapped object
                                     undefined
-                                    (list (cons prop:object cls))
-                                    insp)])
-      (set-class-struct:object! cls struct:object)
-      (set-class-object?! cls object?)
-      (set-class-make-object! cls make-object)
-      (set-class-field-ref! cls field-ref)
-      (set-class-field-set!! cls field-set!)
-      
-      (set-class-orig-cls! cls cls)
-      
-      (let ([init
-             (lambda (o continue-make-super c inited? named-args leftover-args)
-               ;; leftover args will contain the original object and new field values
-               ;; fill the original object in and then fill in the fields.
-               (set-wrapper-object-wrapped! o (car leftover-args))
-               (let loop ([leftover-args (cdr leftover-args)]
-                          [i 0])
-                 (unless (null? leftover-args)
-                   (field-set! o i (car leftover-args))
-                   (loop (cdr leftover-args)
-                         (+ i 1))))
-               (continue-make-super o c inited? '() '() '()))])
-        (set-class-init! cls init))
-      
-      ;; fill in the methods vector & methods-ht
-      (let loop ([i 0]
-                 [methods methods]
-                 [method-ids method-ids])
-        (when (< i method-count)
-          (vector-set! methods-vec i (if old-style? 
-                                         ((car methods) field-ref)
-                                         (car methods)))
-          (vector-set! int-methods-vec i 
-                       (vector (if old-style? 
-                                   ((car methods) field-ref)
-                                   (car methods))))
-          (hash-set! method-ht (car method-ids) i)
-          (loop (+ i 1)
-                (cdr methods)
-                (cdr method-ids))))
-      
-      ;; fill in the fields-ht
-      (let loop ([i 0]
-                 [field-ids field-ids])
-        (when (< i field-count)
-          (hash-set! field-ht (car field-ids) i)
-          (vector-set! int-field-refs i
-                       (make-struct-field-accessor field-ref i #f))
-          (vector-set! int-field-sets i
-                       (make-struct-field-mutator field-set! i #f))
-          (vector-set! ext-field-refs i
-                       (make-struct-field-accessor field-ref i (car field-ids)))
-          (vector-set! ext-field-sets i
-                       (make-struct-field-mutator field-set! i (car field-ids)))
-          (loop (+ i 1)
-                (cdr field-ids))))
-      
-      ;; fill in the supers vector
-      (vector-set! supers 1 cls)
-      
-      cls)))
+                                    ;; Map object property to class:
+                                    (list (cons prop:object c)))])
+      (set-class-struct:object! c struct:object)
+      (set-class-object?! c object?)
+      (set-class-make-object! c object-make)
+      (set-class-field-ref! c object-field-ref)
+      (set-class-field-set!! c object-field-set!))
+    
+    ;; Handle public method contracts
+    (unless (null? methods)
+      ;; First, fill in from old methods
+      (vector-copy! methods 0 (class-methods cls))
+      ;; Now apply projections
+      (for ([m (in-list methods)]
+            [c (in-list method-contracts)])
+        (when c
+          (let ([i (hash-ref method-ht m)]
+                [p ((contract-projection c) blame)])
+            (vector-set! methods i (p (vector-ref methods i)))))))
+    
+    ;; Redirect internal/external field accessors/mutators
+    (let ([old-int-refs (class-int-field-refs cls)]
+          [old-int-sets (class-int-field-sets cls)]
+          [old-ext-refs (class-ext-field-refs cls)]
+          [old-ext-sets (class-ext-field-sets cls)])
+      (for ([i (in-range field-pub-width)])
+        (let ([old-int-ref (vector-ref old-int-refs i)]
+              [old-int-set (vector-ref old-int-sets i)]
+              [old-ext-ref (vector-ref old-ext-refs i)]
+              [old-ext-set (vector-ref old-ext-sets i)])
+          ;; Take in the object, then completely ignore it.
+          (vector-set! int-field-refs i (λ (o) (old-int-ref obj)))
+          (vector-set! int-field-sets i (λ (o) (old-int-set obj)))
+          (vector-set! ext-field-refs i (λ (o) (old-ext-ref obj)))
+          (vector-set! ext-field-sets i (λ (o) (old-ext-set obj))))))
+    
+    ;; Handle external field contracts
+    (unless (null? fields)
+      (let ([bset (blame-swap blame)])
+        (for ([f (in-list fields)]
+              [c (in-list field-contracts)])
+          (when c
+            (let* ([i (hash-ref field-ht f)]
+                   [pre-p (contract-projection c)]
+                   [old-ref (vector-ref ext-field-refs i)]
+                   [old-set (vector-ref ext-field-sets i)])
+              (vector-set! ext-field-refs i
+                           (λ (o) 
+                             ((pre-p blame) (old-ref o))))
+              (vector-set! ext-field-sets i
+                           (λ (o v)
+                             (old-set o ((pre-p bset) v)))))))))
+    
+    c))
 
-; extract-vtable : object -> (vectorof method-proc[this args ... -> res])		
-(define (extract-vtable o) (class-methods (object-ref o)))		
-
-; extract-method-ht : object -> hash-table[sym -> number]		
-(define (extract-method-ht o) (class-method-ht (object-ref o)))
+;; make-wrapper-object: object (listof symbol) (listof contract?) (listof symbol) (listof contract?)
+(define (make-wrapper-object obj blame methods method-contracts fields field-contracts)
+  (check-object-contract obj blame methods fields)
+  (let ([new-cls (make-wrapper-class obj (object-ref obj) blame methods method-contracts fields field-contracts)])
+    ((class-make-object new-cls) obj)))
 
 ;;--------------------------------------------------------------------
 ;;  misc utils
@@ -4626,10 +4595,8 @@
          )
 
 ;; Providing normal functionality:
-(provide (protect-out make-wrapper-class
-                      wrapper-object-wrapped
-                      extract-vtable
-                      extract-method-ht
+(provide (protect-out make-wrapper-object
+                      check-object-contract
                       get-field/proc)
          
          (rename-out [_class class]) class* class/derived
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index e5d746a630..49a9525ae4 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -3043,10 +3043,12 @@
   
   (test/pos-blame
    'object-contract/field2
-   '(contract (object-contract (field x integer?))
-              (new (class object% (field [x #t]) (super-new)))
-              'pos
-              'neg))
+   '(get-field
+     x
+     (contract (object-contract (field x integer?))
+               (new (class object% (field [x #t]) (super-new)))
+               'pos
+               'neg)))
   
   (test/spec-passed/result
    'object-contract/field3
@@ -3060,17 +3062,21 @@
   
   (test/pos-blame
    'object-contract/field4
-   '(contract (object-contract (field x boolean?) (field y boolean?))
-              (new (class object% (field [x #t] [y 'x]) (super-new)))
-              'pos
-              'neg))
+   '(get-field
+     y
+     (contract (object-contract (field x boolean?) (field y boolean?))
+               (new (class object% (field [x #t] [y 'x]) (super-new)))
+               'pos
+               'neg)))
   
   (test/pos-blame
    'object-contract/field5
-   '(contract (object-contract (field x symbol?) (field y symbol?))
-              (new (class object% (field [x #t] [y 'x]) (super-new)))
-              'pos
-              'neg))
+   '(get-field
+     x
+     (contract (object-contract (field x symbol?) (field y symbol?))
+               (new (class object% (field [x #t] [y 'x]) (super-new)))
+               'pos
+               'neg)))
   
   (test/spec-passed/result
    'object-contract/field6

From a3a1d0d9c7246233c412d3e0b66b0151feb147e7 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 22 Feb 2010 22:10:30 +0000
Subject: [PATCH 03/26] Fix shadowing in make-wrapper-class.  Now delay lookup
 for accessors/mutators used for internal field access.  This fixes public
 fields, but not private fields.  Next should fix that up.

Will definitely need to benchmark all this delay though.

svn: r18275
---
 collects/scheme/private/class-internal.ss | 35 +++++++++++++++--------
 1 file changed, 23 insertions(+), 12 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 69f16afef4..17c433bbb3 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -2157,14 +2157,25 @@
               ;; --- Build field accessors and mutators ---
               ;;  Use public field names to name the accessors and mutators
               (let-values ([(local-accessors local-mutators)
-                            (values (for/list ([n (in-range num-fields)]) 
-                                      (make-struct-field-accessor object-field-ref n #f))
-                                    (for/list ([n (in-range num-fields)]) 
-                                      (make-struct-field-mutator object-field-set! n #f)))]
+                            (let ([num-pub-fields (length public-field-names)])
+                              (values (append 
+                                       (for/list ([n (in-range num-pub-fields)])
+                                         (λ (o) ((vector-ref (class-int-field-refs (object-ref o)) n) o)))
+                                       (for/list ([n (in-range num-pub-fields num-fields)])
+                                         (make-struct-field-accessor object-field-ref n #f)))
+                                      (append 
+                                       (for/list ([n (in-range num-pub-fields)])
+                                         (λ (o v) ((vector-ref (class-int-field-sets (object-ref o)) n) o v)))
+                                       (for/list ([n (in-range num-pub-fields num-fields)])
+                                         (make-struct-field-mutator object-field-set! n #f)))))]
                            [(inh-accessors inh-mutators)
-                            (values (map (lambda (id) (vector-ref int-field-refs (hash-ref field-ht id)))
+                            (values (map (lambda (id) 
+                                           (let ([i (hash-ref field-ht id)])
+                                             (λ (o) ((vector-ref (class-int-field-refs (object-ref o)) i) o))))
                                          inherit-field-names)
-                                    (map (lambda (id) (vector-ref int-field-sets (hash-ref field-ht id)))
+                                    (map (lambda (id)
+                                           (let ([i (hash-ref field-ht id)])
+                                             (λ (o v) ((vector-ref (class-int-field-sets (object-ref o)) i) o v))))
                                          inherit-field-names))])
                 
                 ;; -- Extract superclass methods and make rename-inners ---
@@ -4280,9 +4291,9 @@
   (let* ([name (class-name cls)]
          [method-width (class-method-width cls)]
          [method-ht (class-method-ht cls)]
-         [methods (if (null? methods)
-                      (class-methods cls)
-                      (make-vector method-width))]
+         [meths (if (null? methods)
+                    (class-methods cls)
+                    (make-vector method-width))]
          [field-pub-width (class-field-pub-width cls)]
          [field-ht (class-field-ht cls)]
          [int-field-refs (make-vector field-pub-width)]
@@ -4304,7 +4315,7 @@
                         method-ht
                         (class-method-ids cls)
                         
-                        methods
+                        meths
                         (class-super-methods cls)
                         (class-int-methods cls)
                         (class-beta-methods cls)
@@ -4358,14 +4369,14 @@
     ;; Handle public method contracts
     (unless (null? methods)
       ;; First, fill in from old methods
-      (vector-copy! methods 0 (class-methods cls))
+      (vector-copy! meths 0 (class-methods cls))
       ;; Now apply projections
       (for ([m (in-list methods)]
             [c (in-list method-contracts)])
         (when c
           (let ([i (hash-ref method-ht m)]
                 [p ((contract-projection c) blame)])
-            (vector-set! methods i (p (vector-ref methods i)))))))
+            (vector-set! meths i (p (vector-ref meths i)))))))
     
     ;; Redirect internal/external field accessors/mutators
     (let ([old-int-refs (class-int-field-refs cls)]

From 0e3af711768c8a3b8b4d404780b4ec12f9a73fdf Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 22 Feb 2010 22:26:27 +0000
Subject: [PATCH 04/26] So now object-contract works again, but we seem to have
 introduced a bug in the class/c inherit-field form, so now time to fix that.

svn: r18276
---
 collects/scheme/private/class-internal.ss | 91 +++++++++++------------
 1 file changed, 45 insertions(+), 46 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 17c433bbb3..6c415cf12e 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -1775,7 +1775,6 @@
                       dynamic-projs  ; vector of vector of projections for internal dynamic dispatch
                       
                       field-width    ; total number of fields
-                      field-pub-width ; total number of public fields
                       field-ht       ; maps public field names to vector positions
                       field-ids      ; list of public field names
                       
@@ -1892,7 +1891,7 @@
                                   (null? override-names)
                                   (null? augride-names)
                                   (null? final-names))]
-         [no-new-fields? (null? public-field-names)]
+         [no-new-fields? (zero? num-fields)]
          [xappend (lambda (a b) (if (null? b) a (append a b)))])
     
     ;; -- Check interfaces ---
@@ -1935,7 +1934,7 @@
             (hash-set! method-ht (car ids) p)
             (loop (cdr ids) (add1 p)))))
       (unless no-new-fields?
-        (let loop ([ids public-field-names][p (class-field-pub-width super)])
+        (let loop ([ids public-field-names][p (class-field-width super)])
           (unless (null? ids)
             (when (hash-ref field-ht (car ids) #f)
               (obj-error 'class* "superclass ~e already contains field: ~a~a" 
@@ -1970,8 +1969,7 @@
                                 (for-class name)))))
                 ids))]
             [method-width (+ (class-method-width super) (length public-names))]
-            [field-width (+ (class-field-width super) num-fields)]
-            [field-pub-width (+ (class-field-pub-width super) (length public-field-names))])
+            [field-width (+ (class-field-width super) num-fields)])
         (let ([inherit-indices (get-indices super-method-ht "inherit" inherit-names)]
               [replace-augonly-indices (get-indices super-method-ht "overment" overment-names)]
               [replace-final-indices (get-indices super-method-ht "override-final" override-final-names)]
@@ -2057,16 +2055,16 @@
                                  (make-vector method-width))]
                  [int-field-refs (if no-new-fields?
                                      (class-int-field-refs super)
-                                     (make-vector field-pub-width))]
+                                     (make-vector field-width))]
                  [int-field-sets (if no-new-fields?
                                      (class-int-field-sets super)
-                                     (make-vector field-pub-width))]
+                                     (make-vector field-width))]
                  [ext-field-refs (if no-new-fields?
                                      (class-ext-field-refs super)
-                                     (make-vector field-pub-width))]
+                                     (make-vector field-width))]
                  [ext-field-sets (if no-new-fields?
                                      (class-ext-field-sets super)
-                                     (make-vector field-pub-width))]
+                                     (make-vector field-width))]
                  [c (class-make name
                                 (add1 (class-pos super))
                                 (list->vector (append (vector->list (class-supers super)) (list #f)))
@@ -2076,7 +2074,7 @@
                                 method-width method-ht method-names
                                 methods super-methods int-methods beta-methods meth-flags
                                 inner-projs dynamic-idxs dynamic-projs
-                                field-width field-pub-width field-ht field-names
+                                field-width field-ht field-names
                                 int-field-refs int-field-sets ext-field-refs ext-field-sets
                                 'struct:object 'object? 'make-object 'field-ref 'field-set!
                                 init-args
@@ -2146,28 +2144,31 @@
                 (vector-copy! int-field-sets 0 (class-int-field-sets super))
                 (vector-copy! ext-field-refs 0 (class-ext-field-refs super))
                 (vector-copy! ext-field-sets 0 (class-ext-field-sets super))
-                (for ([n (in-range (class-field-pub-width super) field-pub-width)]
-                      [i (in-naturals)]
-                      [id (in-list public-field-names)])
-                  (vector-set! int-field-refs n (make-struct-field-accessor object-field-ref i #f))
-                  (vector-set! int-field-sets n (make-struct-field-mutator object-field-set! i #f))
-                  (vector-set! ext-field-refs n (make-struct-field-accessor object-field-ref i id))
-                  (vector-set! ext-field-sets n (make-struct-field-mutator object-field-set! i id))))
+                (let* ([sup-len (class-field-width super)]
+                       [pub-len (length public-field-names)]
+                       [private-start (+ sup-len pub-len)])
+                  ;; For public fields, set both the internal and external accessors/mutators.
+                  (for ([n (in-range sup-len private-start)]
+                        [i (in-naturals)]
+                        [id (in-list public-field-names)])
+                    (vector-set! int-field-refs n (make-struct-field-accessor object-field-ref i #f))
+                    (vector-set! int-field-sets n (make-struct-field-mutator object-field-set! i #f))
+                    (vector-set! ext-field-refs n (make-struct-field-accessor object-field-ref i id))
+                    (vector-set! ext-field-sets n (make-struct-field-mutator object-field-set! i id)))
+                  ;; For private fields, only set the internal accessor/mutator.
+                  (for ([n (in-range private-start field-width)]
+                        [i (in-naturals)])
+                    (vector-set! int-field-refs n (make-struct-field-accessor object-field-ref i #f))
+                    (vector-set! int-field-sets n (make-struct-field-mutator object-field-set! i #f)))))
               
               ;; --- Build field accessors and mutators ---
               ;;  Use public field names to name the accessors and mutators
               (let-values ([(local-accessors local-mutators)
-                            (let ([num-pub-fields (length public-field-names)])
-                              (values (append 
-                                       (for/list ([n (in-range num-pub-fields)])
-                                         (λ (o) ((vector-ref (class-int-field-refs (object-ref o)) n) o)))
-                                       (for/list ([n (in-range num-pub-fields num-fields)])
-                                         (make-struct-field-accessor object-field-ref n #f)))
-                                      (append 
-                                       (for/list ([n (in-range num-pub-fields)])
-                                         (λ (o v) ((vector-ref (class-int-field-sets (object-ref o)) n) o v)))
-                                       (for/list ([n (in-range num-pub-fields num-fields)])
-                                         (make-struct-field-mutator object-field-set! n #f)))))]
+                            (let ([super-len (class-field-width super)])
+                              (values (for/list ([n (in-range super-len field-width)])
+                                        (λ (o) ((vector-ref (class-int-field-refs (object-ref o)) n) o)))
+                                      (for/list ([n (in-range super-len field-width)])
+                                        (λ (o v) ((vector-ref (class-int-field-sets (object-ref o)) n) o v)))))]
                            [(inh-accessors inh-mutators)
                             (values (map (lambda (id) 
                                            (let ([i (hash-ref field-ht id)])
@@ -2586,20 +2587,20 @@
              [dynamic-projs (if (null? dynamic-features)
                                 (class-dynamic-projs cls)
                                 (make-vector method-width))]
-             [field-pub-width (class-field-pub-width cls)]
+             [field-width (class-field-width cls)]
              [field-ht (class-field-ht cls)]
              [int-field-refs (if (null? (class/c-inherit-fields ctc))
                                  (class-int-field-refs cls)
-                                 (make-vector field-pub-width))]
+                                 (make-vector field-width))]
              [int-field-sets (if (null? (class/c-inherit-fields ctc))
                                  (class-int-field-sets cls)
-                                 (make-vector field-pub-width))]
+                                 (make-vector field-width))]
              [ext-field-refs (if (null? (class/c-fields ctc))
                                  (class-ext-field-refs cls)
-                                 (make-vector field-pub-width))]
+                                 (make-vector field-width))]
              [ext-field-sets (if (null? (class/c-fields ctc))
                                  (class-ext-field-sets cls)
-                                 (make-vector field-pub-width))]
+                                 (make-vector field-width))]
              [class-make (if name
                              (make-naming-constructor 
                               struct:class
@@ -2625,8 +2626,7 @@
                             dynamic-idxs
                             dynamic-projs
                             
-                            (class-field-width cls)
-                            field-pub-width
+                            field-width
                             field-ht
                             (class-field-ids cls)
                             
@@ -3270,7 +3270,7 @@
 
                  (vector) (vector) (vector)
                  
-                 0 0 (make-hasheq) null
+                 0 (make-hasheq) null
                  (vector) (vector) (vector) (vector)
                  
                  'struct:object object? 'make-object
@@ -4294,12 +4294,12 @@
          [meths (if (null? methods)
                     (class-methods cls)
                     (make-vector method-width))]
-         [field-pub-width (class-field-pub-width cls)]
+         [field-width (class-field-width cls)]
          [field-ht (class-field-ht cls)]
-         [int-field-refs (make-vector field-pub-width)]
-         [int-field-sets (make-vector field-pub-width)]
-         [ext-field-refs (make-vector field-pub-width)]
-         [ext-field-sets (make-vector field-pub-width)]
+         [int-field-refs (make-vector field-width)]
+         [int-field-sets (make-vector field-width)]
+         [ext-field-refs (make-vector field-width)]
+         [ext-field-sets (make-vector field-width)]
          [class-make (if name
                          (make-naming-constructor 
                           struct:class
@@ -4325,8 +4325,7 @@
                         (class-dynamic-idxs cls)
                         (class-dynamic-projs cls)
                         
-                        (class-field-width cls)
-                        field-pub-width
+                        field-width
                         field-ht
                         (class-field-ids cls)
                         
@@ -4383,16 +4382,16 @@
           [old-int-sets (class-int-field-sets cls)]
           [old-ext-refs (class-ext-field-refs cls)]
           [old-ext-sets (class-ext-field-sets cls)])
-      (for ([i (in-range field-pub-width)])
+      (for ([i (in-range field-width)])
         (let ([old-int-ref (vector-ref old-int-refs i)]
               [old-int-set (vector-ref old-int-sets i)]
               [old-ext-ref (vector-ref old-ext-refs i)]
               [old-ext-set (vector-ref old-ext-sets i)])
           ;; Take in the object, then completely ignore it.
           (vector-set! int-field-refs i (λ (o) (old-int-ref obj)))
-          (vector-set! int-field-sets i (λ (o) (old-int-set obj)))
+          (vector-set! int-field-sets i (λ (o v) (old-int-set obj v)))
           (vector-set! ext-field-refs i (λ (o) (old-ext-ref obj)))
-          (vector-set! ext-field-sets i (λ (o) (old-ext-set obj))))))
+          (vector-set! ext-field-sets i (λ (o v) (old-ext-set obj v))))))
     
     ;; Handle external field contracts
     (unless (null? fields)

From 2af44afb17ac08e9dacf3561b09285b9995a4c0f Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 22 Feb 2010 22:43:47 +0000
Subject: [PATCH 05/26] Now I see -- I was handling local fields in an
 incorrect manner.  We don't want later projections to affect local accesses
 or mutations -- so we just have to add the unwrap check in case it's a
 wrapped object.

svn: r18277
---
 collects/scheme/private/class-internal.ss | 123 +++++++++++-----------
 1 file changed, 62 insertions(+), 61 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 6c415cf12e..31db1fecb5 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -1749,6 +1749,28 @@
      a))
   (eq-hash-code (member-key-id a)))
 
+;;--------------------------------------------------------------------
+;;  object wrapper for contracts
+;;--------------------------------------------------------------------
+
+(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
+  (let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
+                (make-struct-type 'raw-wrapper-object
+                                  #f
+                                  1
+                                  0)])
+    (values wrapper-object?
+            (lambda (v) (ref v 0))
+            (lambda (o v) (set! o 0 v))
+            struct:wrapper-object)))
+
+;; unwrap-object : (union wrapper-object object) -> object
+(define (unwrap-object o)
+  (let loop ([o o])
+    (if (wrapper-object? o)
+        (loop (wrapper-object-wrapped o))
+        o)))
+
 ;;--------------------------------------------------------------------
 ;;  class implementation
 ;;--------------------------------------------------------------------
@@ -1775,6 +1797,7 @@
                       dynamic-projs  ; vector of vector of projections for internal dynamic dispatch
                       
                       field-width    ; total number of fields
+                      field-pub-width ; total number of public fields
                       field-ht       ; maps public field names to vector positions
                       field-ids      ; list of public field names
                       
@@ -1891,7 +1914,7 @@
                                   (null? override-names)
                                   (null? augride-names)
                                   (null? final-names))]
-         [no-new-fields? (zero? num-fields)]
+         [no-new-fields? (null? public-field-names)]
          [xappend (lambda (a b) (if (null? b) a (append a b)))])
     
     ;; -- Check interfaces ---
@@ -1934,7 +1957,7 @@
             (hash-set! method-ht (car ids) p)
             (loop (cdr ids) (add1 p)))))
       (unless no-new-fields?
-        (let loop ([ids public-field-names][p (class-field-width super)])
+        (let loop ([ids public-field-names][p (class-field-pub-width super)])
           (unless (null? ids)
             (when (hash-ref field-ht (car ids) #f)
               (obj-error 'class* "superclass ~e already contains field: ~a~a" 
@@ -1969,7 +1992,8 @@
                                 (for-class name)))))
                 ids))]
             [method-width (+ (class-method-width super) (length public-names))]
-            [field-width (+ (class-field-width super) num-fields)])
+            [field-width (+ (class-field-width super) num-fields)]
+            [field-pub-width (+ (class-field-pub-width super) (length public-field-names))])
         (let ([inherit-indices (get-indices super-method-ht "inherit" inherit-names)]
               [replace-augonly-indices (get-indices super-method-ht "overment" overment-names)]
               [replace-final-indices (get-indices super-method-ht "override-final" override-final-names)]
@@ -2055,16 +2079,16 @@
                                  (make-vector method-width))]
                  [int-field-refs (if no-new-fields?
                                      (class-int-field-refs super)
-                                     (make-vector field-width))]
+                                     (make-vector field-pub-width))]
                  [int-field-sets (if no-new-fields?
                                      (class-int-field-sets super)
-                                     (make-vector field-width))]
+                                     (make-vector field-pub-width))]
                  [ext-field-refs (if no-new-fields?
                                      (class-ext-field-refs super)
-                                     (make-vector field-width))]
+                                     (make-vector field-pub-width))]
                  [ext-field-sets (if no-new-fields?
                                      (class-ext-field-sets super)
-                                     (make-vector field-width))]
+                                     (make-vector field-pub-width))]
                  [c (class-make name
                                 (add1 (class-pos super))
                                 (list->vector (append (vector->list (class-supers super)) (list #f)))
@@ -2074,7 +2098,7 @@
                                 method-width method-ht method-names
                                 methods super-methods int-methods beta-methods meth-flags
                                 inner-projs dynamic-idxs dynamic-projs
-                                field-width field-ht field-names
+                                field-width field-pub-width field-ht field-names
                                 int-field-refs int-field-sets ext-field-refs ext-field-sets
                                 'struct:object 'object? 'make-object 'field-ref 'field-set!
                                 init-args
@@ -2144,31 +2168,24 @@
                 (vector-copy! int-field-sets 0 (class-int-field-sets super))
                 (vector-copy! ext-field-refs 0 (class-ext-field-refs super))
                 (vector-copy! ext-field-sets 0 (class-ext-field-sets super))
-                (let* ([sup-len (class-field-width super)]
-                       [pub-len (length public-field-names)]
-                       [private-start (+ sup-len pub-len)])
-                  ;; For public fields, set both the internal and external accessors/mutators.
-                  (for ([n (in-range sup-len private-start)]
-                        [i (in-naturals)]
-                        [id (in-list public-field-names)])
-                    (vector-set! int-field-refs n (make-struct-field-accessor object-field-ref i #f))
-                    (vector-set! int-field-sets n (make-struct-field-mutator object-field-set! i #f))
-                    (vector-set! ext-field-refs n (make-struct-field-accessor object-field-ref i id))
-                    (vector-set! ext-field-sets n (make-struct-field-mutator object-field-set! i id)))
-                  ;; For private fields, only set the internal accessor/mutator.
-                  (for ([n (in-range private-start field-width)]
-                        [i (in-naturals)])
-                    (vector-set! int-field-refs n (make-struct-field-accessor object-field-ref i #f))
-                    (vector-set! int-field-sets n (make-struct-field-mutator object-field-set! i #f)))))
+                ;; For public fields, set both the internal and external accessors/mutators.
+                (for ([n (in-range (class-field-pub-width super) field-pub-width)]
+                      [i (in-naturals)]
+                      [id (in-list public-field-names)])
+                  (vector-set! int-field-refs n (make-struct-field-accessor object-field-ref i #f))
+                  (vector-set! int-field-sets n (make-struct-field-mutator object-field-set! i #f))
+                  (vector-set! ext-field-refs n (make-struct-field-accessor object-field-ref i id))
+                  (vector-set! ext-field-sets n (make-struct-field-mutator object-field-set! i id))))
               
               ;; --- Build field accessors and mutators ---
               ;;  Use public field names to name the accessors and mutators
               (let-values ([(local-accessors local-mutators)
-                            (let ([super-len (class-field-width super)])
-                              (values (for/list ([n (in-range super-len field-width)])
-                                        (λ (o) ((vector-ref (class-int-field-refs (object-ref o)) n) o)))
-                                      (for/list ([n (in-range super-len field-width)])
-                                        (λ (o v) ((vector-ref (class-int-field-sets (object-ref o)) n) o v)))))]
+                            (values (for/list ([n (in-range num-fields)])
+                                      (let ([acc (make-struct-field-accessor object-field-ref n #f)])
+                                        (λ (o) (acc (unwrap-object o)))))
+                                    (for/list ([n (in-range num-fields)])
+                                      (let ([acc (make-struct-field-mutator object-field-set! n #f)])
+                                        (λ (o v) (acc (unwrap-object o) v)))))]
                            [(inh-accessors inh-mutators)
                             (values (map (lambda (id) 
                                            (let ([i (hash-ref field-ht id)])
@@ -2587,20 +2604,20 @@
              [dynamic-projs (if (null? dynamic-features)
                                 (class-dynamic-projs cls)
                                 (make-vector method-width))]
-             [field-width (class-field-width cls)]
+             [field-pub-width (class-field-pub-width cls)]
              [field-ht (class-field-ht cls)]
              [int-field-refs (if (null? (class/c-inherit-fields ctc))
                                  (class-int-field-refs cls)
-                                 (make-vector field-width))]
+                                 (make-vector field-pub-width))]
              [int-field-sets (if (null? (class/c-inherit-fields ctc))
                                  (class-int-field-sets cls)
-                                 (make-vector field-width))]
+                                 (make-vector field-pub-width))]
              [ext-field-refs (if (null? (class/c-fields ctc))
                                  (class-ext-field-refs cls)
-                                 (make-vector field-width))]
+                                 (make-vector field-pub-width))]
              [ext-field-sets (if (null? (class/c-fields ctc))
                                  (class-ext-field-sets cls)
-                                 (make-vector field-width))]
+                                 (make-vector field-pub-width))]
              [class-make (if name
                              (make-naming-constructor 
                               struct:class
@@ -2626,7 +2643,8 @@
                             dynamic-idxs
                             dynamic-projs
                             
-                            field-width
+                            (class-field-width cls)
+                            field-pub-width
                             field-ht
                             (class-field-ids cls)
                             
@@ -3270,7 +3288,7 @@
 
                  (vector) (vector) (vector)
                  
-                 0 (make-hasheq) null
+                 0 0 (make-hasheq) null
                  (vector) (vector) (vector) (vector)
                  
                  'struct:object object? 'make-object
@@ -4269,24 +4287,6 @@
 ;;  wrapper for contracts
 ;;--------------------------------------------------------------------
 
-(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
-  (let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
-                (make-struct-type 'raw-wrapper-object
-                                  #f
-                                  1
-                                  0)])
-    (values wrapper-object?
-            (lambda (v) (ref v 0))
-            (lambda (o v) (set! o 0 v))
-            struct:wrapper-object)))
-
-;; unwrap-object : (union wrapper-object object) -> object
-(define (unwrap-object o)
-  (let loop ([o o])
-    (if (wrapper-object? o)
-        (loop (wrapper-object-wrapped o))
-        o)))
-
 (define (make-wrapper-class obj cls blame methods method-contracts fields field-contracts)
   (let* ([name (class-name cls)]
          [method-width (class-method-width cls)]
@@ -4294,12 +4294,12 @@
          [meths (if (null? methods)
                     (class-methods cls)
                     (make-vector method-width))]
-         [field-width (class-field-width cls)]
+         [field-pub-width (class-field-pub-width cls)]
          [field-ht (class-field-ht cls)]
-         [int-field-refs (make-vector field-width)]
-         [int-field-sets (make-vector field-width)]
-         [ext-field-refs (make-vector field-width)]
-         [ext-field-sets (make-vector field-width)]
+         [int-field-refs (make-vector field-pub-width)]
+         [int-field-sets (make-vector field-pub-width)]
+         [ext-field-refs (make-vector field-pub-width)]
+         [ext-field-sets (make-vector field-pub-width)]
          [class-make (if name
                          (make-naming-constructor 
                           struct:class
@@ -4325,7 +4325,8 @@
                         (class-dynamic-idxs cls)
                         (class-dynamic-projs cls)
                         
-                        field-width
+                        (class-field-width cls)
+                        field-pub-width
                         field-ht
                         (class-field-ids cls)
                         
@@ -4382,7 +4383,7 @@
           [old-int-sets (class-int-field-sets cls)]
           [old-ext-refs (class-ext-field-refs cls)]
           [old-ext-sets (class-ext-field-sets cls)])
-      (for ([i (in-range field-width)])
+      (for ([i (in-range field-pub-width)])
         (let ([old-int-ref (vector-ref old-int-refs i)]
               [old-int-set (vector-ref old-int-sets i)]
               [old-ext-ref (vector-ref old-ext-refs i)]

From ab2561e08a0f30c96b1d166bbc8aa43b7f0a3587 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 00:40:59 +0000
Subject: [PATCH 06/26] Now we don't need to recur down to unwrap something,
 but if we get a wrapped primitive object in a method send, we need to unwrap
 all objects for its method.

svn: r18279
---
 collects/scheme/private/class-internal.ss | 66 ++++++++++++-----------
 1 file changed, 36 insertions(+), 30 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 31db1fecb5..8daf066986 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -1765,11 +1765,9 @@
             struct:wrapper-object)))
 
 ;; unwrap-object : (union wrapper-object object) -> object
+;; wrapped objects can only be one level deep, so just do a quick check and unwrap.
 (define (unwrap-object o)
-  (let loop ([o o])
-    (if (wrapper-object? o)
-        (loop (wrapper-object-wrapped o))
-        o)))
+  (if (wrapper-object? o) (wrapper-object-wrapped o) o))
 
 ;;--------------------------------------------------------------------
 ;;  class implementation
@@ -3661,42 +3659,50 @@
                        (syntax->list (syntax (clause ...)))))))])))])
     (values (core-send* #f) (core-send* #t))))
 
+;; wrapped-primitive-object? : any -> boolean
+;; Checks to see if a value is a wrapped object whose class is primitive
+(define (wrapped-primitive-object? o)
+  (and (wrapper-object? o)
+       (let* ([cls (object-ref (unwrap-object o))])
+         ;; Is there a better way to check this?
+         (and (eq? 'stop (class-init-mode cls))
+              (class-no-super-init? cls)))))
+
+;; unwrap-if-primitive : any -> any
+;; If the target is a wrapped primitive object, this unwraps it, otherwise
+;; it's the identity function.
+(define (unwrap-if-primitive o)
+  (if (wrapped-primitive-object? o)
+      (unwrap-object o)
+      o))
+
 ;; find-method/who : symbol[top-level-form/proc-name]
 ;;                   any[object] 
 ;;                   symbol[method-name] 
-;;               -> (values method-proc object)
+;;               -> (values method-proc unwrapper)
 ;; returns the method's procedure and a function to unwrap `this' in the case
-;; that this is a wrapper object that is just "falling thru".
+;; that this is a wrapper object where the original class was a primitive one.
 (define (find-method/who who in-object name #:error? [error? #t])
   (unless (object? in-object)
     (if error?
         (obj-error who "target is not an object: ~e for method: ~a"
                    in-object name)
         (values #f values)))
-  
-  (let-syntax ([loop-body
-                (lambda (stx)
-                  (syntax-case stx ()
-                    [(_ abs-object wrapper-case)
-                     (identifier? (syntax abs-object))
-                     (syntax
-                      (let* ([c (object-ref abs-object)]
-                             [pos (hash-ref (class-method-ht c) name #f)])
-                        (cond
-                          [pos (values (vector-ref (class-methods c) pos) abs-object)]
-                          [(wrapper-object? abs-object) wrapper-case]
-                          [else
-                           (if error?
-                               (obj-error who "no such method: ~a~a"
-                                          name
-                                          (for-class (class-name c)))
-                               (values #f values))])))]))])
-    (loop-body
-     in-object
-     (let loop ([loop-object in-object])
-       (loop-body
-        loop-object
-        (loop (wrapper-object-wrapped loop-object)))))))
+  (let* ([cls (object-ref in-object)]
+         [pos (hash-ref (class-method-ht cls) name #f)]
+         [prim? (wrapped-primitive-object? in-object)])
+    (cond
+      [pos (if prim?
+               ;; If primitive, we need to unwrap _any_ wrapped arguments.
+               (values (λ args (apply (vector-ref (class-methods cls) pos)
+                                      (map unwrap-if-primitive args)))
+                       in-object)
+               (values (vector-ref (class-methods cls) pos) in-object))]
+      [error?
+       (obj-error who "no such method: ~a~a"
+                  name
+                  (for-class (class-name cls)))]
+      [else (values #f values)])))
 
 (define-values (make-class-field-accessor make-class-field-mutator)
   (let ([mk (λ (who which)

From cfdb9dd39b20bbaee62e4a979320cc992af9fe53 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 00:43:25 +0000
Subject: [PATCH 07/26] Time to unveil object/c.

svn: r18280
---
 collects/scheme/private/class-internal.ss | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 8daf066986..ae6324aa08 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -56,7 +56,7 @@
            method-in-interface? interface->method-names class->interface class-info
            (struct-out exn:fail:object)
            make-primitive-class
-           class/c ->m ->*m #| object/c |#
+           class/c ->m ->*m object/c
            
            ;; "keywords":
            private public override augment
@@ -4642,5 +4642,5 @@
          method-in-interface? interface->method-names class->interface class-info
          (struct-out exn:fail:object)
          make-primitive-class
-         class/c ->m ->*m #|object/c|#)
+         class/c ->m ->*m object/c)
 

From f1b0bfdd79bb660a32d22cd12581d9bf450df843 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 00:46:47 +0000
Subject: [PATCH 08/26] Yeah, accessors need arguments.

svn: r18281
---
 collects/scheme/private/class-internal.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index ae6324aa08..a44f3d401e 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -3040,7 +3040,7 @@
             (failed "no public field ~a" m)))))))
 
 (define (object/c-check-first-order ctc obj blame)
-  (check-object-contract obj blame (object/c-methods) (object/c-fields)))
+  (check-object-contract obj blame (object/c-methods ctc) (object/c-fields ctc)))
 
 (define (object/c-proj ctc)
   (λ (blame)

From 53381bbf036d513c837d467567d327f7a8be3a69 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 01:15:11 +0000
Subject: [PATCH 09/26] Remove unwrapping in find-method/who until I figure out
 what I actually need to do.

Also fix up is-a? and subclass? so that they should work the same when
contracts are removed from a program.

svn: r18282
---
 collects/scheme/private/class-internal.ss | 40 ++++++-----------------
 1 file changed, 10 insertions(+), 30 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index a44f3d401e..c2dbe5f38b 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -3659,29 +3659,13 @@
                        (syntax->list (syntax (clause ...)))))))])))])
     (values (core-send* #f) (core-send* #t))))
 
-;; wrapped-primitive-object? : any -> boolean
-;; Checks to see if a value is a wrapped object whose class is primitive
-(define (wrapped-primitive-object? o)
-  (and (wrapper-object? o)
-       (let* ([cls (object-ref (unwrap-object o))])
-         ;; Is there a better way to check this?
-         (and (eq? 'stop (class-init-mode cls))
-              (class-no-super-init? cls)))))
-
-;; unwrap-if-primitive : any -> any
-;; If the target is a wrapped primitive object, this unwraps it, otherwise
-;; it's the identity function.
-(define (unwrap-if-primitive o)
-  (if (wrapped-primitive-object? o)
-      (unwrap-object o)
-      o))
-
 ;; find-method/who : symbol[top-level-form/proc-name]
 ;;                   any[object] 
 ;;                   symbol[method-name] 
-;;               -> (values method-proc unwrapper)
-;; returns the method's procedure and a function to unwrap `this' in the case
-;; that this is a wrapper object where the original class was a primitive one.
+;;               -> (values method-proc object)
+;; returns the method's procedure and the object.  If the object is a contract
+;; wrapped one and the original class was a primitive one, then the method
+;; will automatically unwrap both the object and any wrapped arguments on entry.
 (define (find-method/who who in-object name #:error? [error? #t])
   (unless (object? in-object)
     (if error?
@@ -3689,15 +3673,9 @@
                    in-object name)
         (values #f values)))
   (let* ([cls (object-ref in-object)]
-         [pos (hash-ref (class-method-ht cls) name #f)]
-         [prim? (wrapped-primitive-object? in-object)])
+         [pos (hash-ref (class-method-ht cls) name #f)])
     (cond
-      [pos (if prim?
-               ;; If primitive, we need to unwrap _any_ wrapped arguments.
-               (values (λ args (apply (vector-ref (class-methods cls) pos)
-                                      (map unwrap-if-primitive args)))
-                       in-object)
-               (values (vector-ref (class-methods cls) pos) in-object))]
+      [pos (values (vector-ref (class-methods cls) pos) in-object)]
       [error?
        (obj-error who "no such method: ~a~a"
                   name
@@ -4053,7 +4031,7 @@
    (trace (when (object? v)
             (inspect-event v)))
    (cond
-     [(class? c) ((class-object? c) (unwrap-object v))]
+     [(class? c) ((class-object? (class-orig-cls c)) (unwrap-object v))]
      [(interface? c)
       (and (object? v)
            (implementation? (object-ref (unwrap-object v)) c))]
@@ -4063,7 +4041,9 @@
   (unless (class? c)
     (raise-type-error 'subclass? "class" 1 v c))
   (and (class? v)
-       (let ([p (class-pos c)])
+       (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))))))
 

From 14ab0175c315cc1ed719b82d9c48e045f3e718d4 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 03:15:43 +0000
Subject: [PATCH 10/26] Okay, expanding field accesses and mutations to
 basically inline the unwrapping operation helps a bit, especially with
 inherited fields. Unfortunately, as one might expect, TANSTAAFL applies here.
  In order to make sure that we keep the contracted objects around as much as
 possible to make sure there are no holes, we end up making local and
 inherited field access codes 2-3x more than they did before.  However, this
 is still something on the order of 5x faster than external access.  But blah.

CONTRACTS ARE NOT FREE.  Just ask your local lawyer.

svn: r18285
---
 collects/scheme/private/class-internal.ss | 96 ++++++++++-------------
 collects/scheme/private/classidmap.ss     | 11 ++-
 2 files changed, 47 insertions(+), 60 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index c2dbe5f38b..cbaa8650c0 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -194,6 +194,26 @@
              "used before its definition: ~a"
              orig)))
 
+;;--------------------------------------------------------------------
+;;  object wrapper for contracts
+;;--------------------------------------------------------------------
+
+(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
+  (let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
+                (make-struct-type 'raw-wrapper-object
+                                  #f
+                                  1
+                                  0)])
+    (values wrapper-object?
+            (lambda (v) (ref v 0))
+            (lambda (o v) (set! o 0 v))
+            struct:wrapper-object)))
+
+;; unwrap-object : (union wrapper-object object) -> object
+;; wrapped objects can only be one level deep, so just do a quick check and unwrap.
+(define (unwrap-object o)
+  (if (wrapper-object? o) (wrapper-object-wrapped o) o))
+
 ;;--------------------------------------------------------------------
 ;;  class macros
 ;;--------------------------------------------------------------------
@@ -1165,6 +1185,7 @@
                                      (make-field-map trace-flag
                                                      (quote-syntax the-finder)
                                                      (quote the-obj)
+                                                     (quote-syntax unwrap-object)
                                                      (quote-syntax inherit-field-name)
                                                      (quote-syntax inherit-field-name-localized)
                                                      (quote-syntax inherit-field-accessor)
@@ -1174,6 +1195,7 @@
                                      (make-field-map trace-flag
                                                      (quote-syntax the-finder)
                                                      (quote the-obj)
+                                                     (quote-syntax unwrap-object)
                                                      (quote-syntax local-field)
                                                      (quote-syntax local-field-localized)
                                                      (quote-syntax local-field-accessor)
@@ -1749,26 +1771,6 @@
      a))
   (eq-hash-code (member-key-id a)))
 
-;;--------------------------------------------------------------------
-;;  object wrapper for contracts
-;;--------------------------------------------------------------------
-
-(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
-  (let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
-                (make-struct-type 'raw-wrapper-object
-                                  #f
-                                  1
-                                  0)])
-    (values wrapper-object?
-            (lambda (v) (ref v 0))
-            (lambda (o v) (set! o 0 v))
-            struct:wrapper-object)))
-
-;; unwrap-object : (union wrapper-object object) -> object
-;; wrapped objects can only be one level deep, so just do a quick check and unwrap.
-(define (unwrap-object o)
-  (if (wrapper-object? o) (wrapper-object-wrapped o) o))
-
 ;;--------------------------------------------------------------------
 ;;  class implementation
 ;;--------------------------------------------------------------------
@@ -2179,19 +2181,15 @@
               ;;  Use public field names to name the accessors and mutators
               (let-values ([(local-accessors local-mutators)
                             (values (for/list ([n (in-range num-fields)])
-                                      (let ([acc (make-struct-field-accessor object-field-ref n #f)])
-                                        (λ (o) (acc (unwrap-object o)))))
+                                      (make-struct-field-accessor object-field-ref n #f))
                                     (for/list ([n (in-range num-fields)])
-                                      (let ([acc (make-struct-field-mutator object-field-set! n #f)])
-                                        (λ (o v) (acc (unwrap-object o) v)))))]
+                                      (make-struct-field-mutator object-field-set! n #f)))]
                            [(inh-accessors inh-mutators)
-                            (values (map (lambda (id) 
-                                           (let ([i (hash-ref field-ht id)])
-                                             (λ (o) ((vector-ref (class-int-field-refs (object-ref o)) i) o))))
+                            (values (map (lambda (id)
+                                           (vector-ref int-field-refs (hash-ref field-ht id)))
                                          inherit-field-names)
                                     (map (lambda (id)
-                                           (let ([i (hash-ref field-ht id)])
-                                             (λ (o v) ((vector-ref (class-int-field-sets (object-ref o)) i) o v))))
+                                           (vector-ref int-field-sets (hash-ref field-ht id)))
                                          inherit-field-names))])
                 
                 ;; -- Extract superclass methods and make rename-inners ---
@@ -2731,11 +2729,9 @@
                        [old-ref (vector-ref ext-field-refs i)]
                        [old-set (vector-ref ext-field-sets i)])
                   (vector-set! ext-field-refs i
-                               (λ (o) 
-                                 ((pre-p blame) (old-ref o))))
+                               (λ (o) ((pre-p blame) (old-ref o))))
                   (vector-set! ext-field-sets i
-                               (λ (o v)
-                                 (old-set o ((pre-p bset) v)))))))))
+                               (λ (o v) (old-set o ((pre-p bset) v)))))))))
         
         ;; Handle internal field contracts
         (unless (null? (class/c-inherit-fields ctc))
@@ -2750,11 +2746,9 @@
                        [old-ref (vector-ref int-field-refs i)]
                        [old-set (vector-ref int-field-sets i)])
                   (vector-set! int-field-refs i
-                               (λ (o) 
-                                 ((pre-p blame) (old-ref o))))
+                               (λ (o) ((pre-p blame) (old-ref o))))
                   (vector-set! int-field-sets i
-                               (λ (o v)
-                                 (old-set o ((pre-p bset) v)))))))))
+                               (λ (o v) (old-set o ((pre-p bset) v)))))))))
         
         ;; Now the trickiest of them all, internal dynamic dispatch.
         ;; First we update any dynamic indexes, as applicable.
@@ -4364,21 +4358,13 @@
                 [p ((contract-projection c) blame)])
             (vector-set! meths i (p (vector-ref meths i)))))))
     
-    ;; Redirect internal/external field accessors/mutators
-    (let ([old-int-refs (class-int-field-refs cls)]
-          [old-int-sets (class-int-field-sets cls)]
-          [old-ext-refs (class-ext-field-refs cls)]
-          [old-ext-sets (class-ext-field-sets cls)])
-      (for ([i (in-range field-pub-width)])
-        (let ([old-int-ref (vector-ref old-int-refs i)]
-              [old-int-set (vector-ref old-int-sets i)]
-              [old-ext-ref (vector-ref old-ext-refs i)]
-              [old-ext-set (vector-ref old-ext-sets i)])
-          ;; Take in the object, then completely ignore it.
-          (vector-set! int-field-refs i (λ (o) (old-int-ref obj)))
-          (vector-set! int-field-sets i (λ (o v) (old-int-set obj v)))
-          (vector-set! ext-field-refs i (λ (o) (old-ext-ref obj)))
-          (vector-set! ext-field-sets i (λ (o v) (old-ext-set obj v))))))
+    ;; Fix up internal/external field accessors/mutators
+    ;; Normally we'd redirect these, but since make-field-map now unwraps
+    ;; on all accesses, we just copy over the old vectors.
+    (vector-copy! int-field-refs 0 (class-int-field-refs cls))
+    (vector-copy! int-field-sets 0 (class-int-field-sets cls))
+    (vector-copy! ext-field-refs 0 (class-ext-field-refs cls))
+    (vector-copy! ext-field-sets 0 (class-ext-field-sets cls))
     
     ;; Handle external field contracts
     (unless (null? fields)
@@ -4391,11 +4377,9 @@
                    [old-ref (vector-ref ext-field-refs i)]
                    [old-set (vector-ref ext-field-sets i)])
               (vector-set! ext-field-refs i
-                           (λ (o) 
-                             ((pre-p blame) (old-ref o))))
+                           (λ (o) ((pre-p blame) (old-ref o))))
               (vector-set! ext-field-sets i
-                           (λ (o v)
-                             (old-set o ((pre-p bset) v)))))))))
+                           (λ (o v) (old-set o ((pre-p bset) v)))))))))
     
     c))
 
diff --git a/collects/scheme/private/classidmap.ss b/collects/scheme/private/classidmap.ss
index 54001b8d63..26aa28c34f 100644
--- a/collects/scheme/private/classidmap.ss
+++ b/collects/scheme/private/classidmap.ss
@@ -59,7 +59,7 @@
          [(f . args)
           (quasisyntax/loc stx (#,replace-stx . args))])))))
 
-(define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized
+(define (make-field-map trace-flag the-finder the-obj unwrapper the-binder the-binder-localized
                         field-accessor field-mutator field-pos/null)
   (let ([set!-stx (datum->syntax the-finder 'set!)])
     (mk-set!-trans
@@ -73,7 +73,8 @@
                           [trace (syntax/loc stx (set-event obj (quote id) id))]
                           [set (quasisyntax/loc stx
                                  ((unsyntax field-mutator)
-                                  obj (unsyntax-splicing field-pos/null) id))])
+                                  ((unsyntax unwrapper) obj)
+                                  (unsyntax-splicing field-pos/null) id))])
               (if trace-flag
                   (syntax/loc stx (let* bindings trace set))
                   (syntax/loc stx (let* bindings set))))]
@@ -82,7 +83,8 @@
                           [trace (syntax/loc stx (get-event obj (quote id)))]
                           [call (quasisyntax/loc stx
                                   (((unsyntax field-accessor)
-                                    obj-expr (unsyntax-splicing field-pos/null)) . args))])
+                                    ((unsyntax unwrapper) obj-expr)
+                                    (unsyntax-splicing field-pos/null)) . args))])
               (if trace-flag
                   (syntax/loc stx (let* bindings trace call))
                   (syntax/loc stx (let* bindings call))))]
@@ -91,7 +93,8 @@
                           [trace (syntax/loc stx (get-event obj (quote id)))]
                           [get (quasisyntax/loc stx
                                  ((unsyntax field-accessor)
-                                  obj-expr (unsyntax-splicing field-pos/null)))])
+                                  ((unsyntax unwrapper) obj-expr)
+                                  (unsyntax-splicing field-pos/null)))])
               (if trace-flag
                   (syntax/loc stx (let* bindings trace get))
                   (syntax/loc stx (let* bindings get))))]))))))

From 978a9586f5181d2186ea9a306bfe40fd6659b5e4 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 04:02:03 +0000
Subject: [PATCH 11/26] We no longer need the #:error thing here, because we've
 fixed object-contract for real now.

svn: r18286
---
 collects/scheme/private/class-internal.ss | 20 ++++++++------------
 1 file changed, 8 insertions(+), 12 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index cbaa8650c0..30d3f401c8 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -3660,21 +3660,17 @@
 ;; returns the method's procedure and the object.  If the object is a contract
 ;; wrapped one and the original class was a primitive one, then the method
 ;; will automatically unwrap both the object and any wrapped arguments on entry.
-(define (find-method/who who in-object name #:error? [error? #t])
+(define (find-method/who who in-object name)
   (unless (object? in-object)
-    (if error?
-        (obj-error who "target is not an object: ~e for method: ~a"
-                   in-object name)
-        (values #f values)))
+    (obj-error who "target is not an object: ~e for method: ~a"
+               in-object name))
   (let* ([cls (object-ref in-object)]
          [pos (hash-ref (class-method-ht cls) name #f)])
-    (cond
-      [pos (values (vector-ref (class-methods cls) pos) in-object)]
-      [error?
-       (obj-error who "no such method: ~a~a"
-                  name
-                  (for-class (class-name cls)))]
-      [else (values #f values)])))
+    (if pos
+      (values (vector-ref (class-methods cls) pos) in-object)
+      (obj-error who "no such method: ~a~a"
+                 name
+                 (for-class (class-name cls))))))
 
 (define-values (make-class-field-accessor make-class-field-mutator)
   (let ([mk (λ (who which)

From e9a6aa31ca10b81701893fb69f45657765310b59 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 04:03:39 +0000
Subject: [PATCH 12/26] Remove a load of crap from mzlib's object-contract
 that's no longer needed.

svn: r18287
---
 collects/mzlib/private/contract-object.ss | 107 +++-------------------
 1 file changed, 15 insertions(+), 92 deletions(-)

diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss
index 39bcc4dc4e..f1e4c1dd51 100644
--- a/collects/mzlib/private/contract-object.ss
+++ b/collects/mzlib/private/contract-object.ss
@@ -246,51 +246,6 @@
            (raise-syntax-error 'object-contract "malformed ->pp-rest declaration")]
           [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))
       
-      ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
-      (define (build-methods-stx mtds)
-        
-        (define (last-pair l)
-          (cond
-            [(not (pair? (cdr l))) l]
-            [else (last-pair (cdr l))]))
-        
-        (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
-                   [names (map mtd-name mtds)]
-                   [i 0])
-          (cond
-            [(null? arg-spec-stxss) null]
-            [else (let ([arg-spec-stxs (car arg-spec-stxss)])
-                    (with-syntax ([(cases ...)
-                                   (map (lambda (arg-spec-stx)
-                                          (with-syntax ([i i])
-                                            (syntax-case arg-spec-stx ()
-                                              [(this rest-ids ...)
-                                               (syntax
-                                                ((this rest-ids ...)
-                                                 ((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))]
-                                              [else
-                                               (let-values ([(this rest-ids last-var)
-                                                             (let ([lst (syntax->improper-list arg-spec-stx)])
-                                                               (values (car lst)
-                                                                       (all-but-last (cdr lst))
-                                                                       (cdr (last-pair lst))))])
-                                                 (with-syntax ([this this]
-                                                               [(rest-ids ...) rest-ids]
-                                                               [last-var last-var])
-                                                   (syntax
-                                                    ((this rest-ids ... . last-var)
-                                                     (apply (field-ref this i)
-                                                            (wrapper-object-wrapped this)
-                                                            rest-ids ...
-                                                            last-var)))))])))
-                                        (syntax->list arg-spec-stxs))]
-                                  [name (string->symbol (format "~a method" (syntax->datum (car names))))])
-                      (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)])
-                        (cons (syntax (lambda (field-ref) (let ([name proc]) name)))
-                              (loop (cdr arg-spec-stxss)
-                                    (cdr names)
-                                    (+ i 1))))))])))
-      
       (define (syntax->improper-list stx)
         (define (se->il se)
           (cond
@@ -317,61 +272,29 @@
            (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
                          [(method-name ...) (map mtd-name mtds)]
                          [(method-ctc-var ...) (generate-temporaries mtds)]
-                         [(method-var ...) (generate-temporaries mtds)]
-                         [(method/app-var ...) (generate-temporaries mtds)]
-                         [(methods ...) (build-methods-stx mtds)]
                          
                          [(field-ctc-stx ...) (map fld-ctc-stx flds)]
                          [(field-name ...) (map fld-name flds)]
-                         [(field-ctc-var ...) (generate-temporaries flds)]
-                         [(field-var ...) (generate-temporaries flds)]
-                         [(field/app-var ...) (generate-temporaries flds)])
+                         [(field-ctc-var ...) (generate-temporaries flds)])
              (syntax
               (let ([method-ctc-var method-ctc-stx] 
                     ...
                     [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
                     ...)
-                (let ([method-var (contract-projection method-ctc-var)] 
-                      ...
-                      [field-var (contract-projection field-ctc-var)]
-                      ...)
-                  (let ([cls (make-wrapper-class 'wrapper-class 
-                                                 '(method-name ...)
-                                                 (list methods ...)
-                                                 '(field-name ...)
-                                                 #t)])
-                    (make-contract
-                     #:name
-                     `(object-contract 
-                       ,(build-compound-type-name 'method-name method-ctc-var) ...
-                       ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
-                     #:projection
-                     (lambda (blame)
-                       (let ([method/app-var (method-var blame)] 
-                             ...
-                             [field/app-var (field-var blame)]
-                             ...)
-                         (let ([field-names-list '(field-name ...)])
-                           (lambda (val)
-                             (check-object val blame)
-                             (let ([val-mtd-names
-                                    (interface->method-names
-                                     (object-interface
-                                      val))])
-                               (void)
-                               (check-method val 'method-name val-mtd-names blame)
-                               ...)
-                             
-                             (unless (field-bound? field-name val)
-                               (field-error val 'field-name blame)) ...
-                             
-                             (let ([vtable (extract-vtable val)]
-                                   [method-ht (extract-method-ht val)])
-                               (make-object cls
-                                 val
-                                 (method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ...
-                                 (field/app-var (get-field field-name val)) ...
-                                 )))))))))))))]))))
+                (make-contract
+                 #:name
+                 `(object-contract 
+                   ,(build-compound-type-name 'method-name method-ctc-var) ...
+                   ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
+                 #:projection
+                 (lambda (blame)
+                   (lambda (val)
+                     (make-wrapper-object val blame
+                                          (list 'method-name ...) (list method-ctc-var ...)
+                                          (list 'field-name ...) (list field-ctc-var ...))))
+                 #:first-order
+                 (lambda (val)
+                   (make-wrapper-object obj #f (list 'method-name ...) (list 'field-name ...))))))))]))))
 
 
 (define (check-object val blame)

From e4f7f0032e8670eec7d1441d876d65a79f46222b Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 04:13:09 +0000
Subject: [PATCH 13/26] Get rid of the loop that's no longer a loop, and also
 add in the necessary object unwrapping.

svn: r18288
---
 collects/scheme/private/class-internal.ss | 42 ++++++++++-------------
 1 file changed, 18 insertions(+), 24 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 30d3f401c8..a63c4223d6 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -3836,18 +3836,15 @@
      obj))
   (trace-begin
    (trace (set-event obj id val))
-   (let loop ([obj obj])
-     (let* ([cls (object-ref obj)]
-            [field-ht (class-field-ht cls)]
-            [index (hash-ref field-ht id #f)])
-       (cond
-         [index
-          ((vector-ref (class-ext-field-sets cls) index) obj val)]
-         [else
-          (raise-mismatch-error 
-           'get-field
-           (format "expected an object that has a field named ~s, got " id)
-           obj)])))))
+   (let* ([cls (object-ref obj)]
+          [field-ht (class-field-ht cls)]
+          [index (hash-ref field-ht id #f)])
+     (if index
+         ((vector-ref (class-ext-field-sets cls) index) (unwrap-object obj) val)
+         (raise-mismatch-error 
+          'get-field
+          (format "expected an object that has a field named ~s, got " id)
+          obj)))))
 
 (define-syntaxes (get-field get-field-traced)
   (let ()
@@ -3875,18 +3872,15 @@
      obj))
   (trace-begin
    (trace (get-event obj id))
-   (let loop ([obj obj])
-     (let* ([cls (object-ref obj)]
-            [field-ht (class-field-ht cls)]
-            [index (hash-ref field-ht id #f)])
-       (cond
-         [index
-          ((vector-ref (class-ext-field-refs cls) index) obj)]
-         [else
-          (raise-mismatch-error 
-           'get-field
-           (format "expected an object that has a field named ~s, got " id)
-           obj)])))))
+   (let* ([cls (object-ref obj)]
+          [field-ht (class-field-ht cls)]
+          [index (hash-ref field-ht id #f)])
+     (if index
+         ((vector-ref (class-ext-field-refs cls) index) (unwrap-object obj))
+         (raise-mismatch-error 
+          'get-field
+          (format "expected an object that has a field named ~s, got " id)
+          obj)))))
 
 (define-syntaxes (field-bound? field-bound?-traced)
   (let ()

From 70b5fe6294cef704e00d642f8087d4249499155d Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 04:18:29 +0000
Subject: [PATCH 14/26] Of course, it would help if this was correct.

svn: r18289
---
 collects/mzlib/private/contract-object.ss | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss
index f1e4c1dd51..7b7579fa7b 100644
--- a/collects/mzlib/private/contract-object.ss
+++ b/collects/mzlib/private/contract-object.ss
@@ -294,7 +294,7 @@
                                           (list 'field-name ...) (list field-ctc-var ...))))
                  #:first-order
                  (lambda (val)
-                   (make-wrapper-object obj #f (list 'method-name ...) (list 'field-name ...))))))))]))))
+                   (check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))]))))
 
 
 (define (check-object val blame)

From 6326731a15805a27e8f14170b9af8f7b50668e54 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 04:34:05 +0000
Subject: [PATCH 15/26] Fix the tests that break due to semantic changes in
 object-contract.

svn: r18290
---
 .../tests/mzscheme/contract-mzlib-test.ss     | 34 +++++++++++--------
 1 file changed, 20 insertions(+), 14 deletions(-)

diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss
index f42cfe3396..ce040be792 100644
--- a/collects/tests/mzscheme/contract-mzlib-test.ss
+++ b/collects/tests/mzscheme/contract-mzlib-test.ss
@@ -1652,10 +1652,12 @@ of the contract library does not change over time.
   
   (test/pos-blame
    'object-contract/field2
-   '(contract (object-contract (field x integer?))
-              (new (class object% (field [x #t]) (super-new)))
-              'pos
-              'neg))
+   '(get-field
+     x
+     (contract (object-contract (field x integer?))
+               (new (class object% (field [x #t]) (super-new)))
+               'pos
+               'neg)))
   
   (test/spec-passed/result
    'object-contract/field3
@@ -1669,17 +1671,21 @@ of the contract library does not change over time.
   
   (test/pos-blame
    'object-contract/field4
-   '(contract (object-contract (field x boolean?) (field y boolean?))
-              (new (class object% (field [x #t] [y 'x]) (super-new)))
-              'pos
-              'neg))
+   '(get-field
+     y
+     (contract (object-contract (field x boolean?) (field y boolean?))
+               (new (class object% (field [x #t] [y 'x]) (super-new)))
+               'pos
+               'neg)))
   
   (test/pos-blame
    'object-contract/field5
-   '(contract (object-contract (field x symbol?) (field y symbol?))
-              (new (class object% (field [x #t] [y 'x]) (super-new)))
-              'pos
-              'neg))
+   '(get-field
+     x
+     (contract (object-contract (field x symbol?) (field y symbol?))
+               (new (class object% (field [x #t] [y 'x]) (super-new)))
+               'pos
+               'neg)))
   
   (test/spec-passed/result
    'object-contract/field6
@@ -4521,10 +4527,10 @@ so that propagation occurs.
   
   (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1)
   
-  (ctest #t contract-first-order-passes? 
+  (ctest #f contract-first-order-passes? 
          (object-contract (m (-> integer? integer?)))
          (new object%))
-  (ctest #t contract-first-order-passes? 
+  (ctest #f contract-first-order-passes? 
          (object-contract (m (-> integer? integer?)))
          1)
   

From 09425bc8018f90507ea97753cbbf0f19f4e29764 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 12:51:27 +0000
Subject: [PATCH 16/26] Keep the original class in the supers list.  Also, copy
 over the no-super-init? flag.

svn: r18296
---
 collects/scheme/private/class-internal.ss | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index a63c4223d6..cbc4ef3e4f 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -2570,6 +2570,13 @@
     (λ (cls)
       (class/c-check-first-order ctc cls blame)
       (let* ([name (class-name cls)]
+             ;; Only add a new slot if we're not projecting an already contracted class.
+             [supers (if (eq? (class-orig-cls cls) cls)
+                         (list->vector (append (vector->list (class-supers cls)) (list #f)))
+                         (list->vector (vector->list (class-supers cls))))]
+             [pos (if (eq? (class-orig-cls cls) cls)
+                      (add1 (class-pos cls))
+                      (class-pos cls))]
              [method-width (class-method-width cls)]
              [method-ht (class-method-ht cls)]
              [dynamic-features
@@ -2620,8 +2627,8 @@
                               (string->symbol (format "class:~a" name)))
                              make-class)]
              [c (class-make name
-                            (class-pos cls)
-                            (list->vector (vector->list (class-supers cls)))
+                            pos
+                            supers
                             (class-self-interface cls)
                             void ;; No inspecting
                             
@@ -2658,12 +2665,12 @@
                             
                             (class-orig-cls cls)
                             #f #f ; serializer is never set
-                            #f)]
+                            (class-no-super-init? cls))]
              [obj-name (if name
                            (string->symbol (format "object:~a" name))
                            'object)])
         
-        (vector-set! (class-supers c) (class-pos c) c)
+        (vector-set! supers pos c)
         
         ;; --- Make the new object struct ---
         (let-values ([(struct:object object-make object? object-field-ref object-field-set!)

From 6583b0b77c74dacb06e859d411f28db3300e815e Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 14:55:24 +0000
Subject: [PATCH 17/26] My first foray into the C side of things.

svn: r18299
---
 collects/scheme/private/class-internal.ss |  6 ++--
 src/mzscheme/utils/xcglue.c               | 38 +++++++++++++++++------
 2 files changed, 33 insertions(+), 11 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index cbc4ef3e4f..4fa8f6b260 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -2124,7 +2124,7 @@
             ;; --- Make the new object struct ---
             (let*-values ([(prim-object-make prim-object? struct:prim-object)
                            (if make-struct:prim
-                               (make-struct:prim c prop:object preparer dispatcher (get-properties interfaces))
+                               (make-struct:prim c prop:object preparer dispatcher unwrap-object (get-properties interfaces))
                                (values #f #f #f))]
                           [(struct:object object-make object? object-field-ref object-field-set!)
                            (if make-struct:prim
@@ -4189,7 +4189,7 @@
          new-methods)         ; list of methods
   
   ; The `make-struct:prim' function takes prop:object, a
-  ;  class, a preparer, a dispatcher function, and a property assoc list, and produces:
+  ;  class, a preparer, a dispatcher function, an unwrapper, and a property assoc list, and produces:
   ;    * a struct constructor (must have prop:object)
   ;    * a struct predicate
   ;    * a struct type for derived classes (mustn't have prop:object)
@@ -4198,6 +4198,8 @@
   ; 
   ; The supplied dispatcher takes an object and a num and returns a method.
   ;
+  ; The supplied unwrapper takes an object and returns the unwrapped version (or the original object).
+  ;
   ; When a primitive class has a superclass, the struct:prim maker
   ;  is responsible for ensuring that the returned struct items match
   ;  the supertype predicate.
diff --git a/src/mzscheme/utils/xcglue.c b/src/mzscheme/utils/xcglue.c
index 596fe2bdaa..0aa7e6c8c2 100644
--- a/src/mzscheme/utils/xcglue.c
+++ b/src/mzscheme/utils/xcglue.c
@@ -18,10 +18,10 @@
         arguments v...
 
       (primitive-class-prepare-struct-type! prim-class gen-property
-        gen-value preparer dispatcher extra-props) - prepares a class's 
-        struct-type for objects generated C-side; returns a constructor, 
-        predicate, and a struct:type for derived classes. The constructor and
-        struct:type map the given dispatcher to the class.
+        gen-value preparer dispatcher unwrapper extra-props) - prepares a
+        class's  struct-type for objects generated C-side; returns a
+        constructor,  predicate, and a struct:type for derived classes.
+        The constructor and struct:type map the given dispatcher to the class.
 
         The preparer takes a symbol naming the method. It returns a
         value to be used in future calls to the dispatcher.
@@ -30,6 +30,9 @@
         method-specific value produced by the prepaper. It returns a
         method procedure.
 
+        The unwrapper takes a possibly wrapped object and returns the
+        unwrapped version (or the object if not wrapped).
+
         The extra-props argument is a list of property--value pairs.
 
       (primitive-class-find-method prim-class sym) - gets the method
@@ -96,6 +99,7 @@ static Scheme_Object *object_struct;
 static Scheme_Object *object_property;
 static Scheme_Object *dispatcher_property;
 static Scheme_Object *preparer_property;
+static Scheme_Object *unwrapper_property;
 
 #ifdef MZ_PRECISE_GC
 # include "../gc2/gc2.h"
@@ -170,8 +174,9 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
     scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv);
   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv);
   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);
+  scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 5, argc, argv);
 
-  props = argv[5];
+  props = argv[6];
   while (SCHEME_PAIRP(props)) {
     name = SCHEME_CAR(props);
     if (!SCHEME_PAIRP(name))
@@ -181,8 +186,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
     props = SCHEME_CDR(props);
   }
   if (!SCHEME_NULLP(props))
-    scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 5, argc, argv);
-  props = argv[5];
+    scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv);
+  props = argv[6];
 
   objscheme_something_prepared = 1;
 
@@ -235,7 +240,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
 
   props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]),
 			   scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]),
-					    props));
+					    scheme_make_pair(scheme_make_pair(unwrapper_property, argv[5]),
+							     props)));
   
   stype = scheme_make_struct_type(name,
 				  base_stype, 
@@ -453,7 +459,18 @@ int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
 
 Scheme_Object *objscheme_unwrap(Scheme_Object *o)
 {
-  return o;
+  Scheme_Object *s[1], *unwrapper;
+
+  if (!o)
+    return NULL;
+
+  unwrapper = scheme_struct_type_property_ref(unwrapper_property, (Scheme_Object *)o);
+  if (!unwrapper)
+    return NULL;
+
+  s[0] = o;
+
+  return _scheme_apply(unwrapper, 1, s);
 }
 
 /***************************************************************************/
@@ -523,6 +540,9 @@ void objscheme_init(Scheme_Env *env)
   wxREGGLOB(dispatcher_property);
   dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher"));
 
+  wxREGGLOB(unwrapper_property);
+  unwrapper_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-unwrapper"));
+
   wxREGGLOB(object_struct);
   object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"), 
 					  NULL, NULL,

From aa7062a35e5fb63a0029e42c4412b6d39ec3a508 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 15:01:04 +0000
Subject: [PATCH 18/26] Fix up kernel.ss to include unwrapper, also fix arity
 check now that it takes one more.

svn: r18300
---
 collects/mred/private/kernel.ss | 4 ++--
 src/mzscheme/utils/xcglue.c     | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss
index 794007f5b7..7c257f25ab 100644
--- a/collects/mred/private/kernel.ss
+++ b/collects/mred/private/kernel.ss
@@ -78,9 +78,9 @@
 		   (syntax
 		    (define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
 				   (make-primitive-class
-				    (lambda (class prop:object preparer dispatcher more-props)
+				    (lambda (class prop:object preparer dispatcher unwrapper more-props)
 				      (kernel:primitive-class-prepare-struct-type! 
-				       c prop:object class preparer dispatcher more-props))
+				       c prop:object class preparer dispatcher unwrapper more-props))
 				    kernel:initialize-primitive-object
 				    'print-name super (list intf ...) 'args
 				    '(old ...)
diff --git a/src/mzscheme/utils/xcglue.c b/src/mzscheme/utils/xcglue.c
index 0aa7e6c8c2..54f59c101d 100644
--- a/src/mzscheme/utils/xcglue.c
+++ b/src/mzscheme/utils/xcglue.c
@@ -562,7 +562,7 @@ void objscheme_init(Scheme_Env *env)
   scheme_install_xc_global("primitive-class-prepare-struct-type!",
 			   scheme_make_prim_w_arity(class_prepare_struct_type,
 						    "primitive-class-prepare-struct-type!",
-						    6, 6),
+						    7, 7),
 			   env);
   
   scheme_install_xc_global("primitive-class-find-method",

From 5e07c2e340f92151313447d8a0d72c019eb86b8e Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 15:47:18 +0000
Subject: [PATCH 19/26] Clean up the prop build a bit, and if there's no
 unwrapper, just return the object (since this works like an identity anyway
 if it's not a wrapped object).

svn: r18301
---
 src/mzscheme/utils/xcglue.c | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/mzscheme/utils/xcglue.c b/src/mzscheme/utils/xcglue.c
index 54f59c101d..48363cccf3 100644
--- a/src/mzscheme/utils/xcglue.c
+++ b/src/mzscheme/utils/xcglue.c
@@ -238,10 +238,10 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
   
   /* Type to derive/instantiate from Scheme: */
 
-  props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]),
-			   scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]),
-					    scheme_make_pair(scheme_make_pair(unwrapper_property, argv[5]),
-							     props)));
+  props = scheme_make_pair(scheme_make_pair(unwrapper_property, argv[5]), props);
+  props = scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]), props);
+
+  props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]), props);
   
   stype = scheme_make_struct_type(name,
 				  base_stype, 
@@ -457,18 +457,18 @@ int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
   return !!a;
 }
 
-Scheme_Object *objscheme_unwrap(Scheme_Object *o)
+Scheme_Object *objscheme_unwrap(Scheme_Object *obj)
 {
   Scheme_Object *s[1], *unwrapper;
 
-  if (!o)
+  if (!obj)
     return NULL;
 
-  unwrapper = scheme_struct_type_property_ref(unwrapper_property, (Scheme_Object *)o);
+  unwrapper = scheme_struct_type_property_ref(unwrapper_property, (Scheme_Object *)obj);
   if (!unwrapper)
-    return NULL;
+    return obj;
 
-  s[0] = o;
+  s[0] = obj;
 
   return _scheme_apply(unwrapper, 1, s);
 }

From 1eeb27fc3087a2e2219342cd402dae61ccbbc678 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 15:58:00 +0000
Subject: [PATCH 20/26] Small fixes in make-wrapper-class/object.

svn: r18302
---
 collects/scheme/private/class-internal.ss | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 4fa8f6b260..dfca957367 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -4266,7 +4266,7 @@
 ;;  wrapper for contracts
 ;;--------------------------------------------------------------------
 
-(define (make-wrapper-class obj cls blame methods method-contracts fields field-contracts)
+(define (make-wrapper-class cls blame methods method-contracts fields field-contracts)
   (let* ([name (class-name cls)]
          [method-width (class-method-width cls)]
          [method-ht (class-method-ht cls)]
@@ -4385,8 +4385,8 @@
 ;; make-wrapper-object: object (listof symbol) (listof contract?) (listof symbol) (listof contract?)
 (define (make-wrapper-object obj blame methods method-contracts fields field-contracts)
   (check-object-contract obj blame methods fields)
-  (let ([new-cls (make-wrapper-class obj (object-ref obj) blame methods method-contracts fields field-contracts)])
-    ((class-make-object new-cls) obj)))
+  (let ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)])
+    ((class-make-object new-cls) (unwrap-object obj))))
 
 ;;--------------------------------------------------------------------
 ;;  misc utils

From 472ef1e87313230624d25cdd10b1c646a16c1b74 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 15:59:22 +0000
Subject: [PATCH 21/26] Other cleanups.

svn: r18303
---
 collects/scheme/private/class-internal.ss | 8 ++------
 1 file changed, 2 insertions(+), 6 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index dfca957367..28dd9f988e 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -3040,13 +3040,10 @@
           (unless (hash-ref field-ht m #f)
             (failed "no public field ~a" m)))))))
 
-(define (object/c-check-first-order ctc obj blame)
-  (check-object-contract obj blame (object/c-methods ctc) (object/c-fields ctc)))
-
 (define (object/c-proj ctc)
   (λ (blame)
     (λ (obj)
-      (object/c-check-first-order ctc obj blame)
+      (check-object-contract obj blame (object/c-methods ctc) (object/c-fields ctc))
       (make-wrapper-object obj blame 
                            (object/c-methods ctc) (object/c-method-contracts ctc)
                            (object/c-fields ctc) (object/c-field-contracts ctc)))))
@@ -3076,8 +3073,7 @@
    #:first-order
    (λ (ctc)
      (λ (obj)
-       (with-handlers ([exn:fail:contract? (λ (e) #f)])
-         (object/c-check-first-order ctc obj #f))))))
+       (check-object-contract obj #f (object/c-methods ctc) (object/c-fields ctc))))))
 
 (define-syntax (object/c stx)
   (syntax-case stx ()

From e1cd160a40c09d13b6ae79e18a8ba53becf43571 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 20:57:22 +0000
Subject: [PATCH 22/26] Now that the C code is back at a compile-ready point,
 I'll check in.

svn: r18306
---
 collects/mred/private/kernel.ss           |  4 +-
 collects/scheme/private/class-internal.ss | 52 +++++++++++++----------
 src/mred/wxs/wxs_bmap.cxx                 |  4 +-
 src/mred/wxs/wxs_butn.cxx                 |  4 +-
 src/mred/wxs/wxs_chce.cxx                 |  4 +-
 src/mred/wxs/wxs_ckbx.cxx                 |  4 +-
 src/mred/wxs/wxs_cnvs.cxx                 |  4 +-
 src/mred/wxs/wxs_dc.cxx                   | 24 +++++------
 src/mred/wxs/wxs_evnt.cxx                 | 24 +++++------
 src/mred/wxs/wxs_fram.cxx                 |  4 +-
 src/mred/wxs/wxs_gage.cxx                 |  4 +-
 src/mred/wxs/wxs_gdi.cxx                  | 52 +++++++++++------------
 src/mred/wxs/wxs_item.cxx                 |  8 ++--
 src/mred/wxs/wxs_lbox.cxx                 |  4 +-
 src/mred/wxs/wxs_menu.cxx                 | 12 +++---
 src/mred/wxs/wxs_misc.cxx                 | 16 +++----
 src/mred/wxs/wxs_obj.cxx                  |  4 +-
 src/mred/wxs/wxs_panl.cxx                 |  8 ++--
 src/mred/wxs/wxs_rado.cxx                 |  4 +-
 src/mred/wxs/wxs_slid.cxx                 |  4 +-
 src/mred/wxs/wxs_tabc.cxx                 |  8 ++--
 src/mred/wxs/wxs_win.cxx                  |  4 +-
 src/mzscheme/utils/xcglue.c               | 32 ++++++++------
 src/mzscheme/utils/xcglue.h               |  2 +-
 src/mzscheme/utils/xctocc                 |  4 +-
 25 files changed, 153 insertions(+), 141 deletions(-)

diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss
index 7c257f25ab..7b5042e6a5 100644
--- a/collects/mred/private/kernel.ss
+++ b/collects/mred/private/kernel.ss
@@ -78,9 +78,9 @@
 		   (syntax
 		    (define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
 				   (make-primitive-class
-				    (lambda (class prop:object preparer dispatcher unwrapper more-props)
+				    (lambda (class prop:object preparer dispatcher prop:unwrap unwrapper more-props)
 				      (kernel:primitive-class-prepare-struct-type! 
-				       c prop:object class preparer dispatcher unwrapper more-props))
+				       c prop:object class preparer dispatcher prop:unwrap unwrapper more-props))
 				    kernel:initialize-primitive-object
 				    'print-name super (list intf ...) 'args
 				    '(old ...)
diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 28dd9f988e..b42092c0c0 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -209,10 +209,9 @@
             (lambda (o v) (set! o 0 v))
             struct:wrapper-object)))
 
-;; unwrap-object : (union wrapper-object object) -> object
-;; wrapped objects can only be one level deep, so just do a quick check and unwrap.
-(define (unwrap-object o)
-  (if (wrapper-object? o) (wrapper-object-wrapped o) o))
+(define-values (prop:unwrap object-unwrapper)
+  (let-values ([(prop:unwrap pred acc) (make-struct-type-property 'prop:unwrap)])
+    (values prop:unwrap acc)))
 
 ;;--------------------------------------------------------------------
 ;;  class macros
@@ -1185,7 +1184,7 @@
                                      (make-field-map trace-flag
                                                      (quote-syntax the-finder)
                                                      (quote the-obj)
-                                                     (quote-syntax unwrap-object)
+                                                     (quote-syntax (λ (o) ((object-unwrapper o) o)))
                                                      (quote-syntax inherit-field-name)
                                                      (quote-syntax inherit-field-name-localized)
                                                      (quote-syntax inherit-field-accessor)
@@ -1195,7 +1194,7 @@
                                      (make-field-map trace-flag
                                                      (quote-syntax the-finder)
                                                      (quote the-obj)
-                                                     (quote-syntax unwrap-object)
+                                                     (quote-syntax (λ (o) ((object-unwrapper o) o)))
                                                      (quote-syntax local-field)
                                                      (quote-syntax local-field-localized)
                                                      (quote-syntax local-field-accessor)
@@ -2124,7 +2123,10 @@
             ;; --- Make the new object struct ---
             (let*-values ([(prim-object-make prim-object? struct:prim-object)
                            (if make-struct:prim
-                               (make-struct:prim c prop:object preparer dispatcher unwrap-object (get-properties interfaces))
+                               (make-struct:prim c prop:object 
+                                                 preparer dispatcher
+                                                 prop:unwrap values
+                                                 (get-properties interfaces))
                                (values #f #f #f))]
                           [(struct:object object-make object? object-field-ref object-field-set!)
                            (if make-struct:prim
@@ -2139,6 +2141,7 @@
                                                  ;; Map object property to class:
                                                  (append
                                                   (list (cons prop:object c))
+                                                  (list (cons prop:unwrap values))
                                                   (if deserialize-id
                                                       (list
                                                        (cons prop:serializable
@@ -2680,7 +2683,8 @@
                                         0 ;; No new fields in this class replacement
                                         undefined
                                         ;; Map object property to class:
-                                        (list (cons prop:object c)))])
+                                        (list (cons prop:object c)
+                                              (cons prop:unwrap values)))])
           (set-class-struct:object! c struct:object)
           (set-class-object?! c object?)
           (set-class-make-object! c object-make)
@@ -3306,7 +3310,8 @@
 (vector-set! (class-supers object%) 0 object%)
 (set-class-orig-cls! object% object%)
 (let*-values ([(struct:obj make-obj obj? -get -set!)
-               (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)])
+               (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)
+                                                         (cons prop:unwrap values)) #f)])
   (set-class-struct:object! object% struct:obj)
   (set-class-make-object! object% make-obj))
 (set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes
@@ -3598,7 +3603,7 @@
               traced?
               stx
               (syntax/loc stx receiver)
-              (syntax/loc stx unwrap-object)
+              (syntax/loc stx (λ (o) ((object-unwrapper o) o)))
               (syntax/loc stx method)
               (syntax/loc stx sym)
               args
@@ -3761,7 +3766,7 @@
                      traced?
                      stx
                      (syntax obj)
-                     (syntax/loc stx unwrap-object)
+                     (syntax/loc stx (λ (o) ((object-unwrapper o) o)))
                      (syntax/loc stx ((generic-applicable gen) obj))
                      (syntax/loc stx (generic-name gen))
                      flat-stx
@@ -3843,7 +3848,7 @@
           [field-ht (class-field-ht cls)]
           [index (hash-ref field-ht id #f)])
      (if index
-         ((vector-ref (class-ext-field-sets cls) index) (unwrap-object obj) val)
+         ((vector-ref (class-ext-field-sets cls) index) ((object-unwrapper obj) obj) val)
          (raise-mismatch-error 
           'get-field
           (format "expected an object that has a field named ~s, got " id)
@@ -3879,7 +3884,7 @@
           [field-ht (class-field-ht cls)]
           [index (hash-ref field-ht id #f)])
      (if index
-         ((vector-ref (class-ext-field-refs cls) index) (unwrap-object obj))
+         ((vector-ref (class-ext-field-refs cls) index) ((object-unwrapper obj) obj))
          (raise-mismatch-error 
           'get-field
           (format "expected an object that has a field named ~s, got " id)
@@ -3965,7 +3970,7 @@
                                                                  (quote-syntax id)
                                                                  (quote-syntax method)
                                                                  (quote-syntax method-obj)
-                                                                 (syntax unwrap-object))]
+                                                                 (syntax (λ (o) ((object-unwrapper o) o))))]
                                                           ...)
                                    ()
                                    body0 body1 ...)))))]
@@ -4018,10 +4023,10 @@
    (trace (when (object? v)
             (inspect-event v)))
    (cond
-     [(class? c) ((class-object? (class-orig-cls c)) (unwrap-object v))]
+     [(class? c) ((class-object? (class-orig-cls c)) ((object-unwrapper v) v))]
      [(interface? c)
       (and (object? v)
-           (implementation? (object-ref (unwrap-object v)) c))]
+           (implementation? (object-ref ((object-unwrapper v) v)) c))]
      [else (raise-type-error 'is-a? "class or interface" 1 v c)])))
 
 (define (subclass? v c)
@@ -4039,7 +4044,7 @@
     (raise-type-error 'object-interface "object" o))
   (trace-begin
    (trace (inspect-event o))
-   (class-self-interface (object-ref (unwrap-object o)))))
+   (class-self-interface (object-ref ((object-unwrapper o) o)))))
 
 (define-traced (object-method-arity-includes? o name cnt)
   (unless (object? o)
@@ -4098,7 +4103,7 @@
     (raise-type-error 'object-info "object" o))
   (trace-begin
    (trace (inspect-event o))
-   (let loop ([c (object-ref (unwrap-object o))]
+   (let loop ([c (object-ref ((object-unwrapper o) o))]
               [skipped? #f])
      (if (struct? ((class-insp-mk c)))
          ;; current inspector can inspect this object
@@ -4138,7 +4143,7 @@
       (raise-type-error 'object->vector "object" in-o))
     (trace-begin
      (trace (inspect-event in-o))
-     (let ([o (unwrap-object in-o)])
+     (let ([o ((object-unwrapper in-o) in-o)])
        (list->vector
         (cons
          (string->symbol (format "object:~a" (class-name (object-ref o))))
@@ -4165,8 +4170,8 @@
     (raise-type-error 'object=? "object" o1))
   (unless (object? o2)
     (raise-type-error 'object=? "object" o2))
-  (eq? (unwrap-object o1)
-       (unwrap-object o2)))
+  (eq? ((object-unwrapper o1) o1)
+       ((object-unwrapper o2) o2)))
 
 ;;--------------------------------------------------------------------
 ;;  primitive classes
@@ -4334,7 +4339,8 @@
                                     0 ;; No new fields in this wrapped object
                                     undefined
                                     ;; Map object property to class:
-                                    (list (cons prop:object c)))])
+                                    (list (cons prop:object c)
+                                          (cons prop:unwrap wrapper-object-wrapped)))])
       (set-class-struct:object! c struct:object)
       (set-class-object?! c object?)
       (set-class-make-object! c object-make)
@@ -4382,7 +4388,7 @@
 (define (make-wrapper-object obj blame methods method-contracts fields field-contracts)
   (check-object-contract obj blame methods fields)
   (let ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)])
-    ((class-make-object new-cls) (unwrap-object obj))))
+    ((class-make-object new-cls) ((object-unwrapper obj) obj))))
 
 ;;--------------------------------------------------------------------
 ;;  misc utils
diff --git a/src/mred/wxs/wxs_bmap.cxx b/src/mred/wxs/wxs_bmap.cxx
index 0f76c79987..5f768261a1 100644
--- a/src/mred/wxs/wxs_bmap.cxx
+++ b/src/mred/wxs/wxs_bmap.cxx
@@ -659,7 +659,7 @@ int objscheme_istype_wxBitmap(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxBitmap_class);
   if (objscheme_is_a(obj, os_wxBitmap_class))
     return 1;
   else {
@@ -703,7 +703,7 @@ class wxBitmap *objscheme_unbundle_wxBitmap(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxBitmap_class);
   (void)objscheme_istype_wxBitmap(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_butn.cxx b/src/mred/wxs/wxs_butn.cxx
index c76e2ef8aa..4381a4cb82 100644
--- a/src/mred/wxs/wxs_butn.cxx
+++ b/src/mred/wxs/wxs_butn.cxx
@@ -796,7 +796,7 @@ int objscheme_istype_wxButton(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxButton_class);
   if (objscheme_is_a(obj, os_wxButton_class))
     return 1;
   else {
@@ -840,7 +840,7 @@ class wxButton *objscheme_unbundle_wxButton(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxButton_class);
   (void)objscheme_istype_wxButton(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_chce.cxx b/src/mred/wxs/wxs_chce.cxx
index 75e7408e0f..51b0d790e0 100644
--- a/src/mred/wxs/wxs_chce.cxx
+++ b/src/mred/wxs/wxs_chce.cxx
@@ -899,7 +899,7 @@ int objscheme_istype_wxChoice(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxChoice_class);
   if (objscheme_is_a(obj, os_wxChoice_class))
     return 1;
   else {
@@ -943,7 +943,7 @@ class wxChoice *objscheme_unbundle_wxChoice(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxChoice_class);
   (void)objscheme_istype_wxChoice(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_ckbx.cxx b/src/mred/wxs/wxs_ckbx.cxx
index 67d1a977fd..0e6f50dc7b 100644
--- a/src/mred/wxs/wxs_ckbx.cxx
+++ b/src/mred/wxs/wxs_ckbx.cxx
@@ -821,7 +821,7 @@ int objscheme_istype_wxCheckBox(Scheme_Object *obj, const char *stop, int nullOK
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxCheckBox_class);
   if (objscheme_is_a(obj, os_wxCheckBox_class))
     return 1;
   else {
@@ -865,7 +865,7 @@ class wxCheckBox *objscheme_unbundle_wxCheckBox(Scheme_Object *obj, const char *
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxCheckBox_class);
   (void)objscheme_istype_wxCheckBox(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_cnvs.cxx b/src/mred/wxs/wxs_cnvs.cxx
index 1dde33c3c9..0eae07105f 100644
--- a/src/mred/wxs/wxs_cnvs.cxx
+++ b/src/mred/wxs/wxs_cnvs.cxx
@@ -1419,7 +1419,7 @@ int objscheme_istype_wxCanvas(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxCanvas_class);
   if (objscheme_is_a(obj, os_wxCanvas_class))
     return 1;
   else {
@@ -1463,7 +1463,7 @@ class wxCanvas *objscheme_unbundle_wxCanvas(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxCanvas_class);
   (void)objscheme_istype_wxCanvas(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_dc.cxx b/src/mred/wxs/wxs_dc.cxx
index 59b7f993cf..9f21d5f238 100644
--- a/src/mred/wxs/wxs_dc.cxx
+++ b/src/mred/wxs/wxs_dc.cxx
@@ -2664,7 +2664,7 @@ int objscheme_istype_wxDC(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxDC_class);
   if (objscheme_is_a(obj, os_wxDC_class))
     return 1;
   else {
@@ -2708,7 +2708,7 @@ class wxDC *objscheme_unbundle_wxDC(Scheme_Object *obj, const char *where, int n
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxDC_class);
   (void)objscheme_istype_wxDC(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -3116,7 +3116,7 @@ int objscheme_istype_wxMemoryDC(Scheme_Object *obj, const char *stop, int nullOK
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMemoryDC_class);
   if (objscheme_is_a(obj, os_wxMemoryDC_class))
     return 1;
   else {
@@ -3160,7 +3160,7 @@ class wxMemoryDC *objscheme_unbundle_wxMemoryDC(Scheme_Object *obj, const char *
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMemoryDC_class);
   (void)objscheme_istype_wxMemoryDC(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -3281,7 +3281,7 @@ int objscheme_istype_wxPostScriptDC(Scheme_Object *obj, const char *stop, int nu
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPostScriptDC_class);
   if (objscheme_is_a(obj, os_wxPostScriptDC_class))
     return 1;
   else {
@@ -3325,7 +3325,7 @@ class wxPostScriptDC *objscheme_unbundle_wxPostScriptDC(Scheme_Object *obj, cons
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPostScriptDC_class);
   (void)objscheme_istype_wxPostScriptDC(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -3467,7 +3467,7 @@ int objscheme_istype_basePrinterDC(Scheme_Object *obj, const char *stop, int nul
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_basePrinterDC_class);
   if (objscheme_is_a(obj, os_basePrinterDC_class))
     return 1;
   else {
@@ -3511,7 +3511,7 @@ class basePrinterDC *objscheme_unbundle_basePrinterDC(Scheme_Object *obj, const
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_basePrinterDC_class);
   (void)objscheme_istype_basePrinterDC(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -3671,7 +3671,7 @@ int objscheme_istype_wxGL(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxGL_class);
   if (objscheme_is_a(obj, os_wxGL_class))
     return 1;
   else {
@@ -3715,7 +3715,7 @@ class wxGL *objscheme_unbundle_wxGL(Scheme_Object *obj, const char *where, int n
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxGL_class);
   (void)objscheme_istype_wxGL(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -4029,7 +4029,7 @@ int objscheme_istype_wxGLConfig(Scheme_Object *obj, const char *stop, int nullOK
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxGLConfig_class);
   if (objscheme_is_a(obj, os_wxGLConfig_class))
     return 1;
   else {
@@ -4073,7 +4073,7 @@ class wxGLConfig *objscheme_unbundle_wxGLConfig(Scheme_Object *obj, const char *
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxGLConfig_class);
   (void)objscheme_istype_wxGLConfig(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_evnt.cxx b/src/mred/wxs/wxs_evnt.cxx
index 3d23f9f748..019fd2d8f6 100644
--- a/src/mred/wxs/wxs_evnt.cxx
+++ b/src/mred/wxs/wxs_evnt.cxx
@@ -232,7 +232,7 @@ int objscheme_istype_wxEvent(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxEvent_class);
   if (objscheme_is_a(obj, os_wxEvent_class))
     return 1;
   else {
@@ -275,7 +275,7 @@ class wxEvent *objscheme_unbundle_wxEvent(Scheme_Object *obj, const char *where,
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxEvent_class);
   (void)objscheme_istype_wxEvent(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -502,7 +502,7 @@ int objscheme_istype_wxCommandEvent(Scheme_Object *obj, const char *stop, int nu
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxCommandEvent_class);
   if (objscheme_is_a(obj, os_wxCommandEvent_class))
     return 1;
   else {
@@ -545,7 +545,7 @@ class wxCommandEvent *objscheme_unbundle_wxCommandEvent(Scheme_Object *obj, cons
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxCommandEvent_class);
   (void)objscheme_istype_wxCommandEvent(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -682,7 +682,7 @@ int objscheme_istype_wxPopupEvent(Scheme_Object *obj, const char *stop, int null
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPopupEvent_class);
   if (objscheme_is_a(obj, os_wxPopupEvent_class))
     return 1;
   else {
@@ -725,7 +725,7 @@ class wxPopupEvent *objscheme_unbundle_wxPopupEvent(Scheme_Object *obj, const ch
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPopupEvent_class);
   (void)objscheme_istype_wxPopupEvent(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1041,7 +1041,7 @@ int objscheme_istype_wxScrollEvent(Scheme_Object *obj, const char *stop, int nul
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxScrollEvent_class);
   if (objscheme_is_a(obj, os_wxScrollEvent_class))
     return 1;
   else {
@@ -1084,7 +1084,7 @@ class wxScrollEvent *objscheme_unbundle_wxScrollEvent(Scheme_Object *obj, const
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxScrollEvent_class);
   (void)objscheme_istype_wxScrollEvent(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -2119,7 +2119,7 @@ int objscheme_istype_wxKeyEvent(Scheme_Object *obj, const char *stop, int nullOK
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxKeyEvent_class);
   if (objscheme_is_a(obj, os_wxKeyEvent_class))
     return 1;
   else {
@@ -2162,7 +2162,7 @@ class wxKeyEvent *objscheme_unbundle_wxKeyEvent(Scheme_Object *obj, const char *
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxKeyEvent_class);
   (void)objscheme_istype_wxKeyEvent(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -3019,7 +3019,7 @@ int objscheme_istype_wxMouseEvent(Scheme_Object *obj, const char *stop, int null
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMouseEvent_class);
   if (objscheme_is_a(obj, os_wxMouseEvent_class))
     return 1;
   else {
@@ -3062,7 +3062,7 @@ class wxMouseEvent *objscheme_unbundle_wxMouseEvent(Scheme_Object *obj, const ch
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMouseEvent_class);
   (void)objscheme_istype_wxMouseEvent(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_fram.cxx b/src/mred/wxs/wxs_fram.cxx
index e61cf27edc..5a62c2e802 100644
--- a/src/mred/wxs/wxs_fram.cxx
+++ b/src/mred/wxs/wxs_fram.cxx
@@ -1448,7 +1448,7 @@ int objscheme_istype_wxFrame(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxFrame_class);
   if (objscheme_is_a(obj, os_wxFrame_class))
     return 1;
   else {
@@ -1492,7 +1492,7 @@ class wxFrame *objscheme_unbundle_wxFrame(Scheme_Object *obj, const char *where,
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxFrame_class);
   (void)objscheme_istype_wxFrame(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_gage.cxx b/src/mred/wxs/wxs_gage.cxx
index da11ef6cfa..ae194545c9 100644
--- a/src/mred/wxs/wxs_gage.cxx
+++ b/src/mred/wxs/wxs_gage.cxx
@@ -756,7 +756,7 @@ int objscheme_istype_wxsGauge(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxsGauge_class);
   if (objscheme_is_a(obj, os_wxsGauge_class))
     return 1;
   else {
@@ -800,7 +800,7 @@ class wxsGauge *objscheme_unbundle_wxsGauge(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxsGauge_class);
   (void)objscheme_istype_wxsGauge(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_gdi.cxx b/src/mred/wxs/wxs_gdi.cxx
index 681b1a324f..2658e9f731 100644
--- a/src/mred/wxs/wxs_gdi.cxx
+++ b/src/mred/wxs/wxs_gdi.cxx
@@ -686,7 +686,7 @@ int objscheme_istype_wxFont(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxFont_class);
   if (objscheme_is_a(obj, os_wxFont_class))
     return 1;
   else {
@@ -730,7 +730,7 @@ class wxFont *objscheme_unbundle_wxFont(Scheme_Object *obj, const char *where, i
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxFont_class);
   (void)objscheme_istype_wxFont(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -934,7 +934,7 @@ int objscheme_istype_wxFontList(Scheme_Object *obj, const char *stop, int nullOK
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxFontList_class);
   if (objscheme_is_a(obj, os_wxFontList_class))
     return 1;
   else {
@@ -978,7 +978,7 @@ class wxFontList *objscheme_unbundle_wxFontList(Scheme_Object *obj, const char *
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxFontList_class);
   (void)objscheme_istype_wxFontList(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1320,7 +1320,7 @@ int objscheme_istype_wxColour(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxColour_class);
   if (objscheme_is_a(obj, os_wxColour_class))
     return 1;
   else {
@@ -1364,7 +1364,7 @@ class wxColour *objscheme_unbundle_wxColour(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxColour_class);
   (void)objscheme_istype_wxColour(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1461,7 +1461,7 @@ int objscheme_istype_wxColourDatabase(Scheme_Object *obj, const char *stop, int
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxColourDatabase_class);
   if (objscheme_is_a(obj, os_wxColourDatabase_class))
     return 1;
   else {
@@ -1505,7 +1505,7 @@ class wxColourDatabase *objscheme_unbundle_wxColourDatabase(Scheme_Object *obj,
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxColourDatabase_class);
   (void)objscheme_istype_wxColourDatabase(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1710,7 +1710,7 @@ int objscheme_istype_wxPoint(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPoint_class);
   if (objscheme_is_a(obj, os_wxPoint_class))
     return 1;
   else {
@@ -1753,7 +1753,7 @@ class wxPoint *objscheme_unbundle_wxPoint(Scheme_Object *obj, const char *where,
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPoint_class);
   (void)objscheme_istype_wxPoint(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -2274,7 +2274,7 @@ int objscheme_istype_wxBrush(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxBrush_class);
   if (objscheme_is_a(obj, os_wxBrush_class))
     return 1;
   else {
@@ -2318,7 +2318,7 @@ class wxBrush *objscheme_unbundle_wxBrush(Scheme_Object *obj, const char *where,
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxBrush_class);
   (void)objscheme_istype_wxBrush(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -2471,7 +2471,7 @@ int objscheme_istype_wxBrushList(Scheme_Object *obj, const char *stop, int nullO
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxBrushList_class);
   if (objscheme_is_a(obj, os_wxBrushList_class))
     return 1;
   else {
@@ -2515,7 +2515,7 @@ class wxBrushList *objscheme_unbundle_wxBrushList(Scheme_Object *obj, const char
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxBrushList_class);
   (void)objscheme_istype_wxBrushList(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -3085,7 +3085,7 @@ int objscheme_istype_wxPen(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPen_class);
   if (objscheme_is_a(obj, os_wxPen_class))
     return 1;
   else {
@@ -3129,7 +3129,7 @@ class wxPen *objscheme_unbundle_wxPen(Scheme_Object *obj, const char *where, int
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPen_class);
   (void)objscheme_istype_wxPen(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -3287,7 +3287,7 @@ int objscheme_istype_wxPenList(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPenList_class);
   if (objscheme_is_a(obj, os_wxPenList_class))
     return 1;
   else {
@@ -3331,7 +3331,7 @@ class wxPenList *objscheme_unbundle_wxPenList(Scheme_Object *obj, const char *wh
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPenList_class);
   (void)objscheme_istype_wxPenList(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -3600,7 +3600,7 @@ int objscheme_istype_wxCursor(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxCursor_class);
   if (objscheme_is_a(obj, os_wxCursor_class))
     return 1;
   else {
@@ -3644,7 +3644,7 @@ class wxCursor *objscheme_unbundle_wxCursor(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxCursor_class);
   (void)objscheme_istype_wxCursor(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -4334,7 +4334,7 @@ int objscheme_istype_wxRegion(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxRegion_class);
   if (objscheme_is_a(obj, os_wxRegion_class))
     return 1;
   else {
@@ -4378,7 +4378,7 @@ class wxRegion *objscheme_unbundle_wxRegion(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxRegion_class);
   (void)objscheme_istype_wxRegion(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -4953,7 +4953,7 @@ int objscheme_istype_wxPath(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPath_class);
   if (objscheme_is_a(obj, os_wxPath_class))
     return 1;
   else {
@@ -4997,7 +4997,7 @@ class wxPath *objscheme_unbundle_wxPath(Scheme_Object *obj, const char *where, i
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPath_class);
   (void)objscheme_istype_wxPath(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -5313,7 +5313,7 @@ int objscheme_istype_wxFontNameDirectory(Scheme_Object *obj, const char *stop, i
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxFontNameDirectory_class);
   if (objscheme_is_a(obj, os_wxFontNameDirectory_class))
     return 1;
   else {
@@ -5357,7 +5357,7 @@ class wxFontNameDirectory *objscheme_unbundle_wxFontNameDirectory(Scheme_Object
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxFontNameDirectory_class);
   (void)objscheme_istype_wxFontNameDirectory(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_item.cxx b/src/mred/wxs/wxs_item.cxx
index 9f3581e0da..dae74d1af9 100644
--- a/src/mred/wxs/wxs_item.cxx
+++ b/src/mred/wxs/wxs_item.cxx
@@ -164,7 +164,7 @@ int objscheme_istype_wxItem(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxItem_class);
   if (objscheme_is_a(obj, os_wxItem_class))
     return 1;
   else {
@@ -208,7 +208,7 @@ class wxItem *objscheme_unbundle_wxItem(Scheme_Object *obj, const char *where, i
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxItem_class);
   (void)objscheme_istype_wxItem(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1027,7 +1027,7 @@ int objscheme_istype_wxMessage(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMessage_class);
   if (objscheme_is_a(obj, os_wxMessage_class))
     return 1;
   else {
@@ -1071,7 +1071,7 @@ class wxMessage *objscheme_unbundle_wxMessage(Scheme_Object *obj, const char *wh
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMessage_class);
   (void)objscheme_istype_wxMessage(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_lbox.cxx b/src/mred/wxs/wxs_lbox.cxx
index 930681b1c2..1763247f2f 100644
--- a/src/mred/wxs/wxs_lbox.cxx
+++ b/src/mred/wxs/wxs_lbox.cxx
@@ -1264,7 +1264,7 @@ int objscheme_istype_wxListBox(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxListBox_class);
   if (objscheme_is_a(obj, os_wxListBox_class))
     return 1;
   else {
@@ -1308,7 +1308,7 @@ class wxListBox *objscheme_unbundle_wxListBox(Scheme_Object *obj, const char *wh
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxListBox_class);
   (void)objscheme_istype_wxListBox(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_menu.cxx b/src/mred/wxs/wxs_menu.cxx
index 22029e1e66..47801030de 100644
--- a/src/mred/wxs/wxs_menu.cxx
+++ b/src/mred/wxs/wxs_menu.cxx
@@ -586,7 +586,7 @@ int objscheme_istype_wxMenu(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMenu_class);
   if (objscheme_is_a(obj, os_wxMenu_class))
     return 1;
   else {
@@ -630,7 +630,7 @@ class wxMenu *objscheme_unbundle_wxMenu(Scheme_Object *obj, const char *where, i
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMenu_class);
   (void)objscheme_istype_wxMenu(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -899,7 +899,7 @@ int objscheme_istype_wxMenuBar(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMenuBar_class);
   if (objscheme_is_a(obj, os_wxMenuBar_class))
     return 1;
   else {
@@ -943,7 +943,7 @@ class wxMenuBar *objscheme_unbundle_wxMenuBar(Scheme_Object *obj, const char *wh
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxMenuBar_class);
   (void)objscheme_istype_wxMenuBar(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1119,7 +1119,7 @@ int objscheme_istype_wxsMenuItem(Scheme_Object *obj, const char *stop, int nullO
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxsMenuItem_class);
   if (objscheme_is_a(obj, os_wxsMenuItem_class))
     return 1;
   else {
@@ -1163,7 +1163,7 @@ class wxsMenuItem *objscheme_unbundle_wxsMenuItem(Scheme_Object *obj, const char
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxsMenuItem_class);
   (void)objscheme_istype_wxsMenuItem(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_misc.cxx b/src/mred/wxs/wxs_misc.cxx
index 95f1f71379..9ad9f425c3 100644
--- a/src/mred/wxs/wxs_misc.cxx
+++ b/src/mred/wxs/wxs_misc.cxx
@@ -268,7 +268,7 @@ int objscheme_istype_wxTimer(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxTimer_class);
   if (objscheme_is_a(obj, os_wxTimer_class))
     return 1;
   else {
@@ -312,7 +312,7 @@ class wxTimer *objscheme_unbundle_wxTimer(Scheme_Object *obj, const char *where,
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxTimer_class);
   (void)objscheme_istype_wxTimer(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -608,7 +608,7 @@ int objscheme_istype_wxClipboard(Scheme_Object *obj, const char *stop, int nullO
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxClipboard_class);
   if (objscheme_is_a(obj, os_wxClipboard_class))
     return 1;
   else {
@@ -652,7 +652,7 @@ class wxClipboard *objscheme_unbundle_wxClipboard(Scheme_Object *obj, const char
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxClipboard_class);
   (void)objscheme_istype_wxClipboard(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1022,7 +1022,7 @@ int objscheme_istype_wxClipboardClient(Scheme_Object *obj, const char *stop, int
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxClipboardClient_class);
   if (objscheme_is_a(obj, os_wxClipboardClient_class))
     return 1;
   else {
@@ -1066,7 +1066,7 @@ class wxClipboardClient *objscheme_unbundle_wxClipboardClient(Scheme_Object *obj
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxClipboardClient_class);
   (void)objscheme_istype_wxClipboardClient(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1826,7 +1826,7 @@ int objscheme_istype_wxPrintSetupData(Scheme_Object *obj, const char *stop, int
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPrintSetupData_class);
   if (objscheme_is_a(obj, os_wxPrintSetupData_class))
     return 1;
   else {
@@ -1870,7 +1870,7 @@ class wxPrintSetupData *objscheme_unbundle_wxPrintSetupData(Scheme_Object *obj,
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPrintSetupData_class);
   (void)objscheme_istype_wxPrintSetupData(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_obj.cxx b/src/mred/wxs/wxs_obj.cxx
index 9b1683afe3..8892b107ed 100644
--- a/src/mred/wxs/wxs_obj.cxx
+++ b/src/mred/wxs/wxs_obj.cxx
@@ -120,7 +120,7 @@ int objscheme_istype_wxObject(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxObject_class);
   if (objscheme_is_a(obj, os_wxObject_class))
     return 1;
   else {
@@ -164,7 +164,7 @@ class wxObject *objscheme_unbundle_wxObject(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxObject_class);
   (void)objscheme_istype_wxObject(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_panl.cxx b/src/mred/wxs/wxs_panl.cxx
index 74acfb688c..96b6d92572 100644
--- a/src/mred/wxs/wxs_panl.cxx
+++ b/src/mred/wxs/wxs_panl.cxx
@@ -958,7 +958,7 @@ int objscheme_istype_wxPanel(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPanel_class);
   if (objscheme_is_a(obj, os_wxPanel_class))
     return 1;
   else {
@@ -1002,7 +1002,7 @@ class wxPanel *objscheme_unbundle_wxPanel(Scheme_Object *obj, const char *where,
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxPanel_class);
   (void)objscheme_istype_wxPanel(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1825,7 +1825,7 @@ int objscheme_istype_wxDialogBox(Scheme_Object *obj, const char *stop, int nullO
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxDialogBox_class);
   if (objscheme_is_a(obj, os_wxDialogBox_class))
     return 1;
   else {
@@ -1869,7 +1869,7 @@ class wxDialogBox *objscheme_unbundle_wxDialogBox(Scheme_Object *obj, const char
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxDialogBox_class);
   (void)objscheme_istype_wxDialogBox(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_rado.cxx b/src/mred/wxs/wxs_rado.cxx
index dbc2b4a18d..7dbbaf189c 100644
--- a/src/mred/wxs/wxs_rado.cxx
+++ b/src/mred/wxs/wxs_rado.cxx
@@ -1100,7 +1100,7 @@ int objscheme_istype_wxRadioBox(Scheme_Object *obj, const char *stop, int nullOK
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxRadioBox_class);
   if (objscheme_is_a(obj, os_wxRadioBox_class))
     return 1;
   else {
@@ -1144,7 +1144,7 @@ class wxRadioBox *objscheme_unbundle_wxRadioBox(Scheme_Object *obj, const char *
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxRadioBox_class);
   (void)objscheme_istype_wxRadioBox(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_slid.cxx b/src/mred/wxs/wxs_slid.cxx
index c9a6bc1c14..55c51ae100 100644
--- a/src/mred/wxs/wxs_slid.cxx
+++ b/src/mred/wxs/wxs_slid.cxx
@@ -697,7 +697,7 @@ int objscheme_istype_wxSlider(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxSlider_class);
   if (objscheme_is_a(obj, os_wxSlider_class))
     return 1;
   else {
@@ -741,7 +741,7 @@ class wxSlider *objscheme_unbundle_wxSlider(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxSlider_class);
   (void)objscheme_istype_wxSlider(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_tabc.cxx b/src/mred/wxs/wxs_tabc.cxx
index b6e6b94a49..5a48e075c1 100644
--- a/src/mred/wxs/wxs_tabc.cxx
+++ b/src/mred/wxs/wxs_tabc.cxx
@@ -999,7 +999,7 @@ int objscheme_istype_wxTabChoice(Scheme_Object *obj, const char *stop, int nullO
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxTabChoice_class);
   if (objscheme_is_a(obj, os_wxTabChoice_class))
     return 1;
   else {
@@ -1043,7 +1043,7 @@ class wxTabChoice *objscheme_unbundle_wxTabChoice(Scheme_Object *obj, const char
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxTabChoice_class);
   (void)objscheme_istype_wxTabChoice(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
@@ -1626,7 +1626,7 @@ int objscheme_istype_wxGroupBox(Scheme_Object *obj, const char *stop, int nullOK
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxGroupBox_class);
   if (objscheme_is_a(obj, os_wxGroupBox_class))
     return 1;
   else {
@@ -1670,7 +1670,7 @@ class wxGroupBox *objscheme_unbundle_wxGroupBox(Scheme_Object *obj, const char *
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxGroupBox_class);
   (void)objscheme_istype_wxGroupBox(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mred/wxs/wxs_win.cxx b/src/mred/wxs/wxs_win.cxx
index cbebda495f..0a84d26456 100644
--- a/src/mred/wxs/wxs_win.cxx
+++ b/src/mred/wxs/wxs_win.cxx
@@ -1418,7 +1418,7 @@ int objscheme_istype_wxWindow(Scheme_Object *obj, const char *stop, int nullOK)
 {
   REMEMBER_VAR_STACK();
   if (nullOK && XC_SCHEME_NULLP(obj)) return 1;
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxWindow_class);
   if (objscheme_is_a(obj, os_wxWindow_class))
     return 1;
   else {
@@ -1462,7 +1462,7 @@ class wxWindow *objscheme_unbundle_wxWindow(Scheme_Object *obj, const char *wher
 
   REMEMBER_VAR_STACK();
 
-  obj = objscheme_unwrap(obj);
+  obj = objscheme_unwrap(obj, os_wxWindow_class);
   (void)objscheme_istype_wxWindow(obj, where, nullOK);
   Scheme_Class_Object *o = (Scheme_Class_Object *)obj;
   WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));
diff --git a/src/mzscheme/utils/xcglue.c b/src/mzscheme/utils/xcglue.c
index 48363cccf3..b7c74646d5 100644
--- a/src/mzscheme/utils/xcglue.c
+++ b/src/mzscheme/utils/xcglue.c
@@ -91,6 +91,7 @@ typedef struct Scheme_Class {
   Scheme_Object **methods;
   Scheme_Object *base_struct_type;
   Scheme_Object *struct_type;
+  Scheme_Object *unwrap_property;
 } Scheme_Class;
 
 Scheme_Type objscheme_class_type;
@@ -99,7 +100,6 @@ static Scheme_Object *object_struct;
 static Scheme_Object *object_property;
 static Scheme_Object *dispatcher_property;
 static Scheme_Object *preparer_property;
-static Scheme_Object *unwrapper_property;
 
 #ifdef MZ_PRECISE_GC
 # include "../gc2/gc2.h"
@@ -122,6 +122,7 @@ int gc_class_mark(void *_c)
   gcMARK(c->methods);
   gcMARK(c->base_struct_type);
   gcMARK(c->struct_type);
+  gcMARK(c->unwrap_property);
   
   return gcBYTES_TO_WORDS(sizeof(Scheme_Class));
 }
@@ -137,6 +138,7 @@ int gc_class_fixup(void *_c)
   gcFIXUP(c->methods);
   gcFIXUP(c->base_struct_type);
   gcFIXUP(c->struct_type);
+  gcFIXUP(c->unwrap_property);
   
   return gcBYTES_TO_WORDS(sizeof(Scheme_Class));
 }
@@ -174,9 +176,11 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
     scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv);
   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv);
   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);
-  scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 5, argc, argv);
+  if(SCHEME_TYPE(argv[5]) != scheme_struct_property_type)
+    scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 5, argc, argv);
+  scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 6, argc, argv);
 
-  props = argv[6];
+  props = argv[7];
   while (SCHEME_PAIRP(props)) {
     name = SCHEME_CAR(props);
     if (!SCHEME_PAIRP(name))
@@ -186,8 +190,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
     props = SCHEME_CDR(props);
   }
   if (!SCHEME_NULLP(props))
-    scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv);
-  props = argv[6];
+    scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 7, argc, argv);
+  props = argv[7];
 
   objscheme_something_prepared = 1;
 
@@ -238,7 +242,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
   
   /* Type to derive/instantiate from Scheme: */
 
-  props = scheme_make_pair(scheme_make_pair(unwrapper_property, argv[5]), props);
+  c->unwrap_property = argv[5];
+  props = scheme_make_pair(scheme_make_pair(argv[5], argv[6]), props);
   props = scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]), props);
 
   props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]), props);
@@ -457,14 +462,18 @@ int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
   return !!a;
 }
 
-Scheme_Object *objscheme_unwrap(Scheme_Object *obj)
+Scheme_Object *objscheme_unwrap(Scheme_Object *obj, Scheme_Object *c)
 {
-  Scheme_Object *s[1], *unwrapper;
+  Scheme_Object *s[1], *unwrapper, *unwrap_prop;
+  Scheme_Class *cls = (Scheme_Class *)cls;
 
   if (!obj)
     return NULL;
 
-  unwrapper = scheme_struct_type_property_ref(unwrapper_property, (Scheme_Object *)obj);
+  unwrap_prop = cls->unwrap_property;
+  if(!unwrap_prop)
+    return obj;
+  unwrapper = scheme_struct_type_property_ref(unwrap_prop, (Scheme_Object *)obj);
   if (!unwrapper)
     return obj;
 
@@ -540,9 +549,6 @@ void objscheme_init(Scheme_Env *env)
   wxREGGLOB(dispatcher_property);
   dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher"));
 
-  wxREGGLOB(unwrapper_property);
-  unwrapper_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-unwrapper"));
-
   wxREGGLOB(object_struct);
   object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"), 
 					  NULL, NULL,
@@ -562,7 +568,7 @@ void objscheme_init(Scheme_Env *env)
   scheme_install_xc_global("primitive-class-prepare-struct-type!",
 			   scheme_make_prim_w_arity(class_prepare_struct_type,
 						    "primitive-class-prepare-struct-type!",
-						    7, 7),
+						    8, 8),
 			   env);
   
   scheme_install_xc_global("primitive-class-find-method",
diff --git a/src/mzscheme/utils/xcglue.h b/src/mzscheme/utils/xcglue.h
index aa9631ce59..ef5f496ab9 100644
--- a/src/mzscheme/utils/xcglue.h
+++ b/src/mzscheme/utils/xcglue.h
@@ -78,7 +78,7 @@ Scheme_Object *objscheme_find_method(Scheme_Object *obj,
 int objscheme_is_subclass(Scheme_Object *a, Scheme_Object *sup);
 int objscheme_is_a(Scheme_Object *o, Scheme_Object *c);
 
-Scheme_Object *objscheme_unwrap(Scheme_Object *);
+Scheme_Object *objscheme_unwrap(Scheme_Object *, Scheme_Object *);
 
 Scheme_Object *objscheme_unbox(Scheme_Object *, const char *where);
 Scheme_Object *objscheme_nullable_unbox(Scheme_Object *, const char *where);
diff --git a/src/mzscheme/utils/xctocc b/src/mzscheme/utils/xctocc
index e6d5c7b2f0..e7245e8971 100755
--- a/src/mzscheme/utils/xctocc
+++ b/src/mzscheme/utils/xctocc
@@ -1237,7 +1237,7 @@ sub DoPrintClass
 	print "{\n";
 	print "  REMEMBER_VAR_STACK();\n";
 	print "  if (nullOK && XC_SCHEME_NULLP(obj)) return 1;\n";
-	print "  obj = objscheme_unwrap(obj);\n";
+	print "  obj = objscheme_unwrap(obj, ${newclass}_class);\n";
 	print "  if (objscheme_is_a(obj, ${newclass}_class))\n";
 	print "    return 1;\n";
 	print "  else {\n";
@@ -1288,7 +1288,7 @@ sub DoPrintClass
 	print "{\n";
 	print "  if (nullOK && XC_SCHEME_NULLP(obj)) return NULL;\n\n";
 	print "  REMEMBER_VAR_STACK();\n\n";
-	print "  obj = objscheme_unwrap(obj);\n";
+	print "  obj = objscheme_unwrap(obj, ${newclass}_class);\n";
 	print "  (void)objscheme_istype_${oldclass}(obj, where, nullOK);\n";
 
 	print "  Scheme_Class_Object *o = ";

From f60645da2cb8f5a230fc5129a9bf29f0158f888f Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 21:43:08 +0000
Subject: [PATCH 23/26] ARGHGHGHGHGHGHGHGGHGH

svn: r18308
---
 collects/scheme/private/class-internal.ss | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index b42092c0c0..66293218c0 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -4020,9 +4020,9 @@
 
 (define-traced (is-a? v c)
   (trace-begin
-   (trace (when (object? v)
-            (inspect-event v)))
+   (trace (when (object? v) (inspect-event v)))
    (cond
+     [(not (object? v)) #f]
      [(class? c) ((class-object? (class-orig-cls c)) ((object-unwrapper v) v))]
      [(interface? c)
       (and (object? v)

From 7e6b4757facd75a72a53ffcabe0c35b1b4f08c2f Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 22:40:07 +0000
Subject: [PATCH 24/26] Forgot to check this

svn: r18312
---
 src/mzscheme/utils/xcglue.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/mzscheme/utils/xcglue.c b/src/mzscheme/utils/xcglue.c
index b7c74646d5..1acd8c9884 100644
--- a/src/mzscheme/utils/xcglue.c
+++ b/src/mzscheme/utils/xcglue.c
@@ -467,7 +467,7 @@ Scheme_Object *objscheme_unwrap(Scheme_Object *obj, Scheme_Object *c)
   Scheme_Object *s[1], *unwrapper, *unwrap_prop;
   Scheme_Class *cls = (Scheme_Class *)cls;
 
-  if (!obj)
+  if (!obj || !cls)
     return NULL;
 
   unwrap_prop = cls->unwrap_property;

From 60b6c81f9f08c0b5c9598ade16b46060588fee02 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 23 Feb 2010 23:56:08 +0000
Subject: [PATCH 25/26] Okay, updates to all this crapola.  Going to try and
 see what happens if I only attach prop:unwrap to wrapped objects.

svn: r18313
---
 collects/mred/private/kernel.ss           |  4 +--
 collects/scheme/private/class-internal.ss | 40 ++++++++++-------------
 collects/scheme/private/classidmap.ss     |  8 ++---
 src/mzscheme/utils/xcglue.c               | 16 ++++-----
 4 files changed, 29 insertions(+), 39 deletions(-)

diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss
index 7b5042e6a5..552a2856c7 100644
--- a/collects/mred/private/kernel.ss
+++ b/collects/mred/private/kernel.ss
@@ -78,9 +78,9 @@
 		   (syntax
 		    (define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
 				   (make-primitive-class
-				    (lambda (class prop:object preparer dispatcher prop:unwrap unwrapper more-props)
+				    (lambda (class prop:object preparer dispatcher prop:unwrap more-props)
 				      (kernel:primitive-class-prepare-struct-type! 
-				       c prop:object class preparer dispatcher prop:unwrap unwrapper more-props))
+				       c prop:object class preparer dispatcher prop:unwrap more-props))
 				    kernel:initialize-primitive-object
 				    'print-name super (list intf ...) 'args
 				    '(old ...)
diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 66293218c0..26611adb16 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -211,7 +211,7 @@
 
 (define-values (prop:unwrap object-unwrapper)
   (let-values ([(prop:unwrap pred acc) (make-struct-type-property 'prop:unwrap)])
-    (values prop:unwrap acc)))
+    (values prop:unwrap (λ (o) (if (pred o) (wrapper-object-wrapped o) o)))))
 
 ;;--------------------------------------------------------------------
 ;;  class macros
@@ -1184,7 +1184,7 @@
                                      (make-field-map trace-flag
                                                      (quote-syntax the-finder)
                                                      (quote the-obj)
-                                                     (quote-syntax (λ (o) ((object-unwrapper o) o)))
+                                                     (quote-syntax object-unwrapper)
                                                      (quote-syntax inherit-field-name)
                                                      (quote-syntax inherit-field-name-localized)
                                                      (quote-syntax inherit-field-accessor)
@@ -1194,7 +1194,7 @@
                                      (make-field-map trace-flag
                                                      (quote-syntax the-finder)
                                                      (quote the-obj)
-                                                     (quote-syntax (λ (o) ((object-unwrapper o) o)))
+                                                     (quote-syntax object-unwrapper)
                                                      (quote-syntax local-field)
                                                      (quote-syntax local-field-localized)
                                                      (quote-syntax local-field-accessor)
@@ -2125,7 +2125,7 @@
                            (if make-struct:prim
                                (make-struct:prim c prop:object 
                                                  preparer dispatcher
-                                                 prop:unwrap values
+                                                 prop:unwrap
                                                  (get-properties interfaces))
                                (values #f #f #f))]
                           [(struct:object object-make object? object-field-ref object-field-set!)
@@ -2141,7 +2141,6 @@
                                                  ;; Map object property to class:
                                                  (append
                                                   (list (cons prop:object c))
-                                                  (list (cons prop:unwrap values))
                                                   (if deserialize-id
                                                       (list
                                                        (cons prop:serializable
@@ -2683,8 +2682,7 @@
                                         0 ;; No new fields in this class replacement
                                         undefined
                                         ;; Map object property to class:
-                                        (list (cons prop:object c)
-                                              (cons prop:unwrap values)))])
+                                        (list (cons prop:object c)))])
           (set-class-struct:object! c struct:object)
           (set-class-object?! c object?)
           (set-class-make-object! c object-make)
@@ -3310,8 +3308,7 @@
 (vector-set! (class-supers object%) 0 object%)
 (set-class-orig-cls! object% object%)
 (let*-values ([(struct:obj make-obj obj? -get -set!)
-               (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)
-                                                         (cons prop:unwrap values)) #f)])
+               (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)])
   (set-class-struct:object! object% struct:obj)
   (set-class-make-object! object% make-obj))
 (set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes
@@ -3603,7 +3600,6 @@
               traced?
               stx
               (syntax/loc stx receiver)
-              (syntax/loc stx (λ (o) ((object-unwrapper o) o)))
               (syntax/loc stx method)
               (syntax/loc stx sym)
               args
@@ -3766,7 +3762,6 @@
                      traced?
                      stx
                      (syntax obj)
-                     (syntax/loc stx (λ (o) ((object-unwrapper o) o)))
                      (syntax/loc stx ((generic-applicable gen) obj))
                      (syntax/loc stx (generic-name gen))
                      flat-stx
@@ -3848,7 +3843,7 @@
           [field-ht (class-field-ht cls)]
           [index (hash-ref field-ht id #f)])
      (if index
-         ((vector-ref (class-ext-field-sets cls) index) ((object-unwrapper obj) obj) val)
+         ((vector-ref (class-ext-field-sets cls) index) (object-unwrapper obj) val)
          (raise-mismatch-error 
           'get-field
           (format "expected an object that has a field named ~s, got " id)
@@ -3884,7 +3879,7 @@
           [field-ht (class-field-ht cls)]
           [index (hash-ref field-ht id #f)])
      (if index
-         ((vector-ref (class-ext-field-refs cls) index) ((object-unwrapper obj) obj))
+         ((vector-ref (class-ext-field-refs cls) index) (object-unwrapper obj))
          (raise-mismatch-error 
           'get-field
           (format "expected an object that has a field named ~s, got " id)
@@ -3969,8 +3964,7 @@
                                                                  (quote-syntax set!)
                                                                  (quote-syntax id)
                                                                  (quote-syntax method)
-                                                                 (quote-syntax method-obj)
-                                                                 (syntax (λ (o) ((object-unwrapper o) o))))]
+                                                                 (quote-syntax method-obj))]
                                                           ...)
                                    ()
                                    body0 body1 ...)))))]
@@ -4023,10 +4017,10 @@
    (trace (when (object? v) (inspect-event v)))
    (cond
      [(not (object? v)) #f]
-     [(class? c) ((class-object? (class-orig-cls c)) ((object-unwrapper v) v))]
+     [(class? c) ((class-object? (class-orig-cls c)) (object-unwrapper v))]
      [(interface? c)
       (and (object? v)
-           (implementation? (object-ref ((object-unwrapper v) v)) c))]
+           (implementation? (object-ref (object-unwrapper v)) c))]
      [else (raise-type-error 'is-a? "class or interface" 1 v c)])))
 
 (define (subclass? v c)
@@ -4044,7 +4038,7 @@
     (raise-type-error 'object-interface "object" o))
   (trace-begin
    (trace (inspect-event o))
-   (class-self-interface (object-ref ((object-unwrapper o) o)))))
+   (class-self-interface (object-ref (object-unwrapper o)))))
 
 (define-traced (object-method-arity-includes? o name cnt)
   (unless (object? o)
@@ -4103,7 +4097,7 @@
     (raise-type-error 'object-info "object" o))
   (trace-begin
    (trace (inspect-event o))
-   (let loop ([c (object-ref ((object-unwrapper o) o))]
+   (let loop ([c (object-ref (object-unwrapper o))]
               [skipped? #f])
      (if (struct? ((class-insp-mk c)))
          ;; current inspector can inspect this object
@@ -4143,7 +4137,7 @@
       (raise-type-error 'object->vector "object" in-o))
     (trace-begin
      (trace (inspect-event in-o))
-     (let ([o ((object-unwrapper in-o) in-o)])
+     (let ([o (object-unwrapper in-o)])
        (list->vector
         (cons
          (string->symbol (format "object:~a" (class-name (object-ref o))))
@@ -4170,8 +4164,8 @@
     (raise-type-error 'object=? "object" o1))
   (unless (object? o2)
     (raise-type-error 'object=? "object" o2))
-  (eq? ((object-unwrapper o1) o1)
-       ((object-unwrapper o2) o2)))
+  (eq? (object-unwrapper o1)
+       (object-unwrapper o2)))
 
 ;;--------------------------------------------------------------------
 ;;  primitive classes
@@ -4388,7 +4382,7 @@
 (define (make-wrapper-object obj blame methods method-contracts fields field-contracts)
   (check-object-contract obj blame methods fields)
   (let ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)])
-    ((class-make-object new-cls) ((object-unwrapper obj) obj))))
+    ((class-make-object new-cls) (object-unwrapper obj))))
 
 ;;--------------------------------------------------------------------
 ;;  misc utils
diff --git a/collects/scheme/private/classidmap.ss b/collects/scheme/private/classidmap.ss
index 26aa28c34f..3aa5eac5ed 100644
--- a/collects/scheme/private/classidmap.ss
+++ b/collects/scheme/private/classidmap.ss
@@ -270,7 +270,7 @@
      stx)))
 
 (define (make-with-method-map trace-flag set!-stx id-stx
-                              method-stx method-obj-stx unwrap-stx)
+                              method-stx method-obj-stx)
   (make-set!-transformer
    (lambda (stx)
      (syntax-case stx ()
@@ -287,7 +287,6 @@
            trace-flag
            stx
            method-obj-stx
-           unwrap-stx
            method-stx
            (syntax (quote id))
            flat-args-stx
@@ -346,7 +345,7 @@
   (and (pair? ctx)
        (class-context? (car ctx))))
 
-(define (make-method-call traced? source-stx object-stx unwrap-stx
+(define (make-method-call traced? source-stx object-stx
                           method-proc-stx method-name-stx args-stx rest-arg?)
   
   (define-syntax (qstx stx)
@@ -360,7 +359,6 @@
     (if traced?
         (with-syntax ([(mth obj) (generate-temporaries
                                   (list object-stx method-proc-stx))]
-                      [unwrap unwrap-stx]
                       [name method-name-stx]
                       [(arg ...) (qstx args)]
                       [(var ...) (generate-temporaries (qstx args))])
@@ -368,7 +366,7 @@
                       [obj object]
                       [var arg] ...)
                   (initialize-call-event
-                   (unwrap obj) name (app list var ...))
+                   obj name (app list var ...))
                   (call-with-values (lambda () (app mth obj var ...))
                                     finalize-call-event))))
         (qstx (app method object . args)))))
diff --git a/src/mzscheme/utils/xcglue.c b/src/mzscheme/utils/xcglue.c
index 1acd8c9884..2454fe7777 100644
--- a/src/mzscheme/utils/xcglue.c
+++ b/src/mzscheme/utils/xcglue.c
@@ -18,7 +18,7 @@
         arguments v...
 
       (primitive-class-prepare-struct-type! prim-class gen-property
-        gen-value preparer dispatcher unwrapper extra-props) - prepares a
+        gen-value preparer dispatcher unwrap-prop extra-props) - prepares a
         class's  struct-type for objects generated C-side; returns a
         constructor,  predicate, and a struct:type for derived classes.
         The constructor and struct:type map the given dispatcher to the class.
@@ -30,8 +30,8 @@
         method-specific value produced by the prepaper. It returns a
         method procedure.
 
-        The unwrapper takes a possibly wrapped object and returns the
-        unwrapped version (or the object if not wrapped).
+        The unwrap-prop takes a property that, if found on an object,
+	is paired with a function that unwraps the object.
 
         The extra-props argument is a list of property--value pairs.
 
@@ -178,9 +178,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
   scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);
   if(SCHEME_TYPE(argv[5]) != scheme_struct_property_type)
     scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 5, argc, argv);
-  scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 6, argc, argv);
 
-  props = argv[7];
+  props = argv[6];
   while (SCHEME_PAIRP(props)) {
     name = SCHEME_CAR(props);
     if (!SCHEME_PAIRP(name))
@@ -190,8 +189,8 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
     props = SCHEME_CDR(props);
   }
   if (!SCHEME_NULLP(props))
-    scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 7, argc, argv);
-  props = argv[7];
+    scheme_wrong_type("primitive-class-prepare-struct-type!", "list of struct-type-property--value pairs", 6, argc, argv);
+  props = argv[6];
 
   objscheme_something_prepared = 1;
 
@@ -243,7 +242,6 @@ static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv)
   /* Type to derive/instantiate from Scheme: */
 
   c->unwrap_property = argv[5];
-  props = scheme_make_pair(scheme_make_pair(argv[5], argv[6]), props);
   props = scheme_make_pair(scheme_make_pair(dispatcher_property, argv[4]), props);
 
   props = scheme_make_pair(scheme_make_pair(preparer_property, argv[3]), props);
@@ -568,7 +566,7 @@ void objscheme_init(Scheme_Env *env)
   scheme_install_xc_global("primitive-class-prepare-struct-type!",
 			   scheme_make_prim_w_arity(class_prepare_struct_type,
 						    "primitive-class-prepare-struct-type!",
-						    8, 8),
+						    7, 7),
 			   env);
   
   scheme_install_xc_global("primitive-class-find-method",

From af0387e3a6f4b794654eebdcee428abfad4a3b20 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Wed, 24 Feb 2010 16:35:30 +0000
Subject: [PATCH 26/26] Fuck you, C, and the flea-bitten, mange-covered,
 syphilis-ridden horse you rode in on.

svn: r18318
---
 collects/scheme/private/class-internal.ss | 3 +++
 src/mzscheme/utils/xcglue.c               | 3 ++-
 2 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 26611adb16..9d1dc06670 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -211,6 +211,9 @@
 
 (define-values (prop:unwrap object-unwrapper)
   (let-values ([(prop:unwrap pred acc) (make-struct-type-property 'prop:unwrap)])
+    ;; Instead of using the accessor if it has prop:unwrap, just use the unwrapper
+    ;; from wrapper-object directly, since we know it must be a wrapped object.
+    ;; (The accessor will just give us that anyway.)
     (values prop:unwrap (λ (o) (if (pred o) (wrapper-object-wrapped o) o)))))
 
 ;;--------------------------------------------------------------------
diff --git a/src/mzscheme/utils/xcglue.c b/src/mzscheme/utils/xcglue.c
index 2454fe7777..f170640f23 100644
--- a/src/mzscheme/utils/xcglue.c
+++ b/src/mzscheme/utils/xcglue.c
@@ -463,7 +463,7 @@ int objscheme_is_a(Scheme_Object *o, Scheme_Object *c)
 Scheme_Object *objscheme_unwrap(Scheme_Object *obj, Scheme_Object *c)
 {
   Scheme_Object *s[1], *unwrapper, *unwrap_prop;
-  Scheme_Class *cls = (Scheme_Class *)cls;
+  Scheme_Class *cls = (Scheme_Class *)c;
 
   if (!obj || !cls)
     return NULL;
@@ -471,6 +471,7 @@ Scheme_Object *objscheme_unwrap(Scheme_Object *obj, Scheme_Object *c)
   unwrap_prop = cls->unwrap_property;
   if(!unwrap_prop)
     return obj;
+
   unwrapper = scheme_struct_type_property_ref(unwrap_prop, (Scheme_Object *)obj);
   if (!unwrapper)
     return obj;