add stronger to implementation?/c and subclass?/c

also, bring down below 102 cols

pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt

@@ -330,6 +330,15 @@
          (is-a?/c one-interface<%>) 
          (is-a?/c (class* object% (one-interface<%>) (super-new))))
   
+  (ctest #t contract-stronger? (subclass?/c (class object% (super-new))) (subclass?/c object%))
+  (ctest #f contract-stronger? (subclass?/c object%) (subclass?/c (class object% (super-new))))
+  (ctest #t contract-stronger?
+         (implementation?/c another-interface<%>)
+         (implementation?/c one-interface<%>))
+  (ctest #f contract-stronger?
+         (implementation?/c one-interface<%>)
+         (implementation?/c another-interface<%>))
+  
   ;; chances are, this predicate will accept "x", but
   ;; we don't want to consider it stronger, since it 
   ;; will not always accept "x".

racket/collects/racket/contract/private/object.rkt

@@ -71,10 +71,13 @@
      (with-syntax ([(((method-id method-ctc) ...)
                      ((field-id field-ctc) ...))
                     (parse-object-contract stx #'(spec ...))])
-       (with-syntax ([(method-name ...) (map (λ (x) (string->symbol (format "~a method" (syntax-e x)))) 
+       (with-syntax ([(method-name ...)
+                      (map (λ (x) (string->symbol (format "~a method" (syntax-e x))))
                            (syntax->list #'(method-id ...)))])
          #'(build-object-contract '(method-id ...)
-                                  (syntax-parameterize ((making-a-method #t)) (list (let ([method-name method-ctc]) method-name) ...))
+                                  (syntax-parameterize
+                                   ((making-a-method #t))
+                                   (list (let ([method-name method-ctc]) method-name) ...))
                                   '(field-id ...)
                                   (list field-ctc ...))))]))
 
@@ -90,25 +93,39 @@
                    (apply and/c (map sub/impl?/c %/<%>s)))])
        [res (c%) (subclass?/c c%)]))
 
+(struct subclass/c (%)
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:first-order (λ (ctc) (define % (subclass/c-% ctc)) (λ (x) (subclass? x %)))
+   #:stronger (λ (this that)
+                (cond
+                  [(subclass/c? that)
+                   (subclass? (subclass/c-% this) (subclass/c-% that))]
+                  [else #f]))
+   #:name (λ (ctc) `(subclass?/c ,(or (object-name (subclass/c-% ctc)) 'unknown%)))))
 (define (subclass?/c %)
   (unless (class? %)
-    (raise-argument-error 'subclass?/c
+    (raise-argument-error 'subclass?/c "class?" %))
-                          "class?"
+  (subclass/c %))
-                          %))
+
-  (define name (object-name %))
+(struct implementation/c (<%>)
-  (flat-named-contract
+  #:property prop:custom-write custom-write-property-proc
-   `(subclass?/c ,(or name 'unknown%))
+  #:property prop:flat-contract
-   (lambda (x) (subclass? x %))))
+  (build-flat-contract-property
+   #:first-order (λ (ctc) (define <%> (implementation/c-<%> ctc)) (λ (x) (implementation? x <%>)))
+   #:stronger (λ (this that)
+                (cond
+                  [(implementation/c? that)
+                   (interface-extension? (implementation/c-<%> this)
+                                         (implementation/c-<%> that))]
+                  [else #f]))
+   #:name (λ (ctc) `(implementation?/c ,(or (object-name (implementation/c-<%> ctc)) 'unknown<%>)))))
             
 (define (implementation?/c <%>)
   (unless (interface? <%>)
-    (raise-argument-error 'implementation?/c
+    (raise-argument-error 'implementation?/c "interface?" <%>))
-                          "interface?"
+  (implementation/c <%>))
-                          <%>))
-  (define name (object-name <%>))
-  (flat-named-contract
-   `(implementation?/c ,(or name 'unknown<%>))
-   (lambda (x) (implementation? x <%>))))
 
 (define (sub/impl?/c %/<%>)
   (cond