Change instanceof/c to allow more contracts.

Now instanceof/c no longer checks explicitly for a class/c contract, so
or/c or and/c of class/c contracts succeed.

collects/racket/private/class-internal.rkt

@@ -3141,22 +3141,37 @@
          (syntax/loc stx
            (make-base-object/c methods method-ctcs fields field-ctcs))))]))
 
-(define-struct (base-instanceof/c base-object/c) (class-ctc)
+(define (instanceof/c-proj ctc)
+  (let ([proj (contract-projection (base-instanceof/c-class-ctc ctc))])
+    (λ (blame)
+      (let ([p (proj blame)])
+        (λ (val)
+          (unless (object? val)
+            (raise-blame-error blame val "expected an object, got ~v" val))
+          (let ([original-obj (if (has-original-object? val) (original-object val) val)]
+                [new-cls (p (object-ref val))])
+            (impersonate-struct val object-ref (λ (o c) new-cls)
+                                impersonator-prop:contracted ctc
+                                impersonator-prop:original-object original-obj)))))))
+
+(define (instanceof/c-first-order ctc)
+  (let ([cls-ctc (base-instanceof/c-class-ctc ctc)])
+    (λ (val)
+      (and (object? val)
+           (contract-first-order-passes? cls-ctc (object-ref val))))))
+
+(define-struct base-instanceof/c (class-ctc)
   #:property prop:contract
   (build-contract-property 
-   #:projection object/c-proj
+   #:projection instanceof/c-proj
    #:name
    (λ (ctc)
      (build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc)))
-   #:first-order object/c-first-order))
+   #:first-order instanceof/c-first-order))
 
 (define (instanceof/c cctc)
   (let ([ctc (coerce-contract 'instanceof/c cctc)])
-    (unless (class/c? ctc)
+    (make-base-instanceof/c ctc)))
-      (error "expected class contract, got ~v" ctc))
-    (make-base-instanceof/c (class/c-methods ctc) (class/c-method-contracts ctc)
-                          (class/c-fields ctc) (class/c-field-contracts ctc)
-                          ctc)))
 
 ;;--------------------------------------------------------------------
 ;;  interfaces

collects/scribblings/reference/class.scrbl

@@ -1627,11 +1627,8 @@ behaves as if its class had been wrapped with the equivalent
 }
                              
 @defproc[(instanceof/c [class-contract contract?]) contract?]{
-Produces a contract for an instance of a class that conforms
+Produces a contract for an object, where the object is an
-to @scheme[class-contract].
+instance of a class that conforms to @scheme[class-contract].
-
-The resulting contract checks only the external field and method
-contracts listed in @scheme[class-contract].
 }
                              
 @defform/subs[

collects/tests/racket/contract-test.rktl

@@ -7539,6 +7539,27 @@
            [c%/c (class/c [m (->m number? number?)])])
       (contract (instanceof/c c%/c) (new c%) 'pos 'neg)))
   
+  (test/spec-passed
+   'instanceof/c-first-order-6
+   '(let* ([c% (class object% (super-new) (define/public (m x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])])
+      (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)))
+  
+  (test/spec-passed
+   'instanceof/c-first-order-7
+   '(let* ([d% (class object% (super-new) (define/public (n x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])])
+      (contract (instanceof/c (or/c c%/c d%/c)) (new d%) 'pos 'neg)))
+  
+  (test/pos-blame
+   'instanceof/c-first-order-8
+   '(let* ([e% (class object% (super-new) (define/public (p x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])])
+      (contract (instanceof/c (or/c c%/c d%/c)) (new e%) 'pos 'neg)))
+  
   (test/spec-passed/result
    'instanceof/c-higher-order-1
    '(let* ([c% (class object% (super-new) (field [f 3]))]
@@ -7561,6 +7582,30 @@
            [o (contract (instanceof/c c%/c) (new c%) 'pos 'neg)])
       (send o m 3)))
   
+  (test/spec-passed
+   'instanceof/c-higher-order-4
+   '(let* ([c% (class object% (super-new) (define/public (m x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])]
+           [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)])
+      (send o m 3)))
+  
+  (test/pos-blame
+   'instanceof/c-higher-order-4
+   '(let* ([c% (class object% (super-new) (define/public (m x) #t))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])]
+           [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)])
+      (send o m 3)))
+  
+  (test/neg-blame
+   'instanceof/c-higher-order-4
+   '(let* ([c% (class object% (super-new) (define/public (m x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])]
+           [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)])
+      (send o m #t)))
+
 ;                                                                                    
 ;                                                                                    
 ;