diff --git a/pkgs/racket-doc/file/scribblings/ico.scrbl b/pkgs/racket-doc/file/scribblings/ico.scrbl
index 3753e84b8a..f69335df06 100644
--- a/pkgs/racket-doc/file/scribblings/ico.scrbl
+++ b/pkgs/racket-doc/file/scribblings/ico.scrbl
@@ -10,7 +10,8 @@ and writing @filepath{.ico} files, which contain one or more icons.
 Each icon is up to 256 by 256 pixels, has a particular depth (i.e.,
 bits per pixel used to represent a color), and mask (i.e., whether a
 pixel is shown, except that the mask may be ignored for 32-bit icons
-that have an alpha value per pixel).
+that have an alpha value per pixel). The library also provides support
+for reading and writing icons in Windows executables.
 
 @defproc[(ico? [v any/c]) boolean?]{
 
@@ -18,25 +19,40 @@ Returns @racket[#t] if @racket[v] represents an icon, @racket[#f]
 otherwise.}
 
 @deftogether[(
-@defproc[(ico-width [ico ico?]) (integer-in 1 256)]
-@defproc[(ico-height [ico ico?]) (integer-in 1 256)]
+@defproc[(ico-width [ico ico?]) exact-positive-integer?]
+@defproc[(ico-height [ico ico?]) exact-positive-integer?]
 @defproc[(ico-depth [ico ico?]) (one-of/c 1 2 4 8 16 24 32)]
 )]{
 
 Returns the width or height of an icon in pixels, or the depth in bits per
-pixel.}
+pixel.
+
+@history[#:changed "6.2.900.10" @elem{A PNG-format icon can have a
+                                      width or height greater than 256.}]}
+
+
+@deftogether[(
+@defproc[(ico-format [ico ico?]) (or/c 'bmp 'png)]
+)]{
+
+Reports the format of the icon.
+
+@history[#:added "6.2.900.10"]}
+
 
 @defproc[(read-icos [src (or/c path-string? input-port?)])
          (listof ico?)]{
 
 Parses @racket[src] as an @filepath{.ico} to extract a list of icons.}
 
+
 @defproc[(read-icos-from-exe [src (or/c path-string? input-port?)])
          (listof ico?)]{
 
 Parses @racket[src] as an @filepath{.exe} to extract the list of
 icons that represent the Windows executable.}
 
+
 @defproc[(write-icos [icos (listof ico?)]
                      [dest (or/c path-string? output-port?)]
                      [#:exists exists (or/c 'error 'append 'update 'can-update
@@ -50,22 +66,46 @@ Writes each icon in @racket[icos] to @racket[dest] as an
 @racket[exists] is passed on to @racket[open-output-file] to open
 @racket[dest] for writing.}
 
+
 @defproc[(replace-icos [icos (listof ico?)]
-                       [dest (or/c path-string? output-port?)])
+                       [dest path-string?])
           void?]{
 
 Writes icons in @racket[icos] to replace icons in @racket[dest] as an
 Windows executable. Only existing icon sizes and depths in the
-executable are replaced, and best matches for the existing sizes and
-depth are drawn from @racket[icos] (adjusting the scale and depth f a
-best match as necessary).}
+executable are replaced, and only when the encoding sizes match.
+Best matches for the existing sizes and
+depth are drawn from @racket[icos] (adjusting the scale and depth of a
+best match as necessary).
+
+Use @racket[replace-all-icos], instead, to replace a set of icons
+wholesale, especially when the set include PNG-format icons.}
+
+
+@defproc[(replace-all-icos [icos (listof ico?)]
+                           [dest (or/c path-string? output-port?)])
+          void?]{
+
+Replaces the icon set in the executable @racket[dest] with the given
+set of icons.}
+
 
 @defproc[(ico->argb [ico ico?]) bytes?]{
 
-Converts an icon to an ARGB byte string, which has the icon's pixels
+Converts an icon in BMP format (see @racket[ico-format])
+to an ARGB byte string, which has the icon's pixels
 in left-to-right, top-to-bottom order, with four bytes (alpha, red,
 green, and blue channels) for each pixel.}
 
+
+@defproc[(ico->png-bytes [ico ico?]) bytes?]{
+
+Returns the bytes of a PNG encoding for an icon in PNG format (see
+@racket[ico-format]).
+
+@history[#:added "6.2.900.10"]}
+
+
 @defproc[(argb->ico [width (integer-in 1 256)]
                     [height (integer-in 1 256)]
                     [bstr bytes?]
@@ -73,7 +113,16 @@ green, and blue channels) for each pixel.}
          ico?]{
 
 Converts an ARGB byte string (in the same format as from
-@racket[ico->argb]) to an icon of the given width, height, and depth.
+@racket[ico->argb]) to an icon of the given width, height, and depth
+in BMP format.
 
 The @racket[bstr] argument must have a length @racket[(* 4 width height)],
 and @racket[(* width depth)] must be a multiple of 8.}
+
+
+@defproc[(png-bytes->ico [bstr bytes?])
+         ico?]{
+
+Wraps the given PNG encoding as a PNG-encoded icon.
+
+@history[#:added "6.2.900.10"]}
diff --git a/racket/collects/compiler/private/pe-rsrc.rkt b/racket/collects/compiler/private/pe-rsrc.rkt
new file mode 100644
index 0000000000..be11e2e7ad
--- /dev/null
+++ b/racket/collects/compiler/private/pe-rsrc.rkt
@@ -0,0 +1,606 @@
+#lang racket/base
+(require racket/contract
+         racket/pretty)
+
+(provide read-pe+resources
+         update-resources
+
+         resource-ref
+         resource-ref/path
+         resource-set
+         resource-remove)
+
+(define (byte->integer p)
+  (read-byte p))
+(define (word->integer p)
+  (integer-bytes->integer (read-bytes 2 p) #f #f))
+(define (dword->integer p)
+  (integer-bytes->integer (read-bytes 4 p) #f #f))
+(define (xword->integer p)
+  (integer-bytes->integer (read-bytes 8 p) #f #f))
+
+(define (integer->word i p)
+  (display (integer->integer-bytes i 2 #f #f) p))
+(define (integer->dword i p)
+  (display (integer->integer-bytes i 4 #f #f) p))
+(define (integer->3/2word i p)
+  (display (subbytes (integer->integer-bytes i 4 #f #f) 0 3) p))
+
+(define (flag v)
+  (positive? (bitwise-and #x80000000 v)))
+(define (value v)
+  (bitwise-and #x7FFFFFFF v))
+(define (add-flag v)
+  (bitwise-ior #x80000000 v))
+
+(define-logger pe-rsrc)
+
+(define (skip-to-image-headers-after-signature p)
+  ;; p is expected to be a file port
+  (define dos-sig (word->integer p))
+  (unless (= #x5A4D dos-sig)
+    (error 'pe-rsrc "bad DOS signature ~x" dos-sig))
+  (file-position p 60)
+  (let ([pos (dword->integer p)])
+    ;; pos points to IMAGE_NT_HEADERS
+    ;; (log-error "at ~s" pos)
+    (file-position p pos)
+    (define sig (dword->integer p))
+    (unless (= #x4550 sig) ; = #"PE\0\0"
+      (error 'pe-rsrc "bad PE signature ~x" sig))
+    pos))
+
+(struct pe (sections section-alignment file-alignment
+                     image-size-pos section-start-pos rsrc-offset rsrc-virtual-addr rsrc-size))
+(struct section (name virtual-size virtual-addr
+                      file-length file-position
+                      characteristics)
+        #:prefab)
+
+(define (read-pe p)
+  (let ([pos (skip-to-image-headers-after-signature p)])
+    (word->integer p) ; skip machine
+    (let ([num-sections (word->integer p)]
+          [_ (begin (dword->integer p) ; date time stamp
+                    (dword->integer p) ; symbol table - 0 for modern exes
+                    (dword->integer p))] ; symbol count - 0 for modern exes
+          [size (word->integer p)]) ; size of optional headers
+      (file-position p (+ pos 4 20))
+      (define image-type
+        (case (word->integer p)
+          [(#x10B) 'pe32]
+          [(#x20B) 'pe32+]
+          [else (error "unrecognized image type")]))
+      (file-position p (+ pos 4 20 32))
+      (define section-alignment (dword->integer p))
+      (define file-alignment (dword->integer p))
+      (log-pe-rsrc-debug "alignment ~x ~x" section-alignment file-alignment)
+      (define image-size-pos (+ pos 4 20 56))
+      (file-position p image-size-pos)
+      (log-pe-rsrc-debug "image size ~x" (dword->integer p))
+      ;;(file-position p (+ pos 4 20 64))
+      ;;(log-error "checksum ~x at ~a" (dword->integer p) (+ pos 4 20 64))
+      ;;(file-position p (+ pos 4 20 (if (eq? image-type 'pe32) 92 108)))
+      ;;(log-error "extra entries ~a in ~a" (dword->integer p) size)
+      (define rsrc-offset (+ pos 4 20 (if (eq? image-type 'pe32) 112 128)))
+      (file-position p rsrc-offset)
+      (define rsrc-virtual-addr (dword->integer p))
+      (define rsrc-size (dword->integer p))
+      (define section-start-pos (+ pos
+                                   4       ; Signature : DWORD
+                                   20      ; FileHeader: IMAGE_FILE_HEADER
+                                   size))  ; "optional" header
+      (define (z v) (unless (zero? v) (error "expected zero")))
+      (pe (let sloop ([i 0] [section-pos section-start-pos])
+            (if (= i num-sections)
+                null
+                (begin
+                  (file-position p section-pos)
+                  ;; p points to an IMAGE_SECTION_HEADER
+                  (cons (section (read-bytes 8 p)   ; name
+                                 (dword->integer p) ; virtual size
+                                 (dword->integer p) ; virtual address
+                                 (dword->integer p) ; length
+                                 (dword->integer p) ; file pos
+                                 (begin
+                                   (z (dword->integer p)) ; relocations (zero)
+                                   (z (dword->integer p)) ; line numbers (zero)
+                                   (z (word->integer p))  ; num relocations (zero)
+                                   (z (word->integer p))  ; num line numbers (zero)
+                                   (dword->integer p))) ; characteristics
+                        (sloop (add1 i) (+ section-pos 40))))))
+          section-alignment
+          file-alignment
+          image-size-pos
+          section-start-pos
+          rsrc-offset
+          rsrc-virtual-addr
+          rsrc-size))))
+
+(define (show-sections sections)
+  (for/fold ([prev-end 0] [prev-full-end 0]) ([s (in-list sections)])
+    (log-pe-rsrc-debug "~s ~x [+~x/+~x] @ ~x  ~x [-> ~x] $~x"
+                       (section-name s)
+                       (section-virtual-addr s)
+                       (- (section-virtual-addr s) prev-end)
+                       (- (section-virtual-addr s) prev-full-end)
+                       (section-file-position s)
+                       (section-file-length s)
+                       (section-virtual-size s)
+                       (section-characteristics s))
+    (values (+ (section-virtual-addr s)
+               (section-virtual-size s))
+            (+ (section-virtual-addr s)
+               (section-file-length s))))
+  (void))
+
+(define (show-resources rsrcs [indent ""])
+  (cond
+   [(directory? rsrcs)
+    (log-pe-rsrc-debug "~a~s" indent (entry-name rsrcs))
+    (for ([e (in-list (directory-content rsrcs))])
+      (show-resources e (string-append indent "  ")))]
+   [else
+    (log-pe-rsrc-debug "~a~s ~x ~s at ~x" indent (entry-name rsrcs)
+                       (bytes-length (resource-content rsrcs))
+                       (resource-codepage rsrcs)
+                       (resource-file-pos rsrcs))]))
+
+(struct entry (name) #:prefab)
+(struct directory entry (timestamp major-version minor-version content) #:prefab)
+(struct resource entry (content codepage file-pos) #:prefab)
+
+(define (read-rsrcs p rsrc-pos rsrc-virtual-addr)
+  (let loop ([dir-name #f] [dir-pos 0] [depth 0])
+    (file-position p (+ rsrc-pos dir-pos 4))
+    (let ([timestamp (dword->integer p)]
+          [major-version (word->integer p)]
+          [minor-version (word->integer p)]
+          [num-named (word->integer p)]
+          [num-ided (word->integer p)])
+      ;;(log-error "dir at ~x[~a]: ~a+~a" dir-pos depth num-named num-ided)
+      (directory
+       dir-name
+       timestamp
+       major-version
+       minor-version
+       (let iloop ([i 0])
+         (if (= i (+ num-ided num-named))
+             null
+             (let ([name-delta (dword->integer p)]
+                   [data-delta (dword->integer p)]
+                   [next (file-position p)])
+               (cons
+                (let ([name (if (i . < . num-named)
+                                (begin
+                                  ;;(log-error "name at ~x = ~x" (value name-delta) (+ rsrc-pos (value name-delta)))
+                                  (file-position p (+ rsrc-pos (value name-delta)))
+                                  (let* ([len (word->integer p)])
+                                    ;; len is in unicode chars...
+                                    (let ([unistr (read-bytes (* 2 len) p)])
+                                      ;; Assume it fits into ASCII...
+                                      (regexp-replace* "\0" 
+                                                       (bytes->string/latin-1 unistr)
+                                                       ""))))
+                                name-delta)])
+                  (if (flag data-delta)
+                      ;; Directory:
+                      (loop name (value data-delta) (add1 depth))
+                      ;; Entry:
+                      (begin
+                        (file-position p (+ rsrc-pos (value data-delta)))
+                        (let ([rva (dword->integer p)]
+                              [size (dword->integer p)]
+                              [codepage (dword->integer p)])
+                          ;;(log-error "resource at ~x ~x" (value data-delta) size)
+                          (define file-pos (+ rva
+                                              (- rsrc-pos
+                                                 rsrc-virtual-addr)))
+                          (file-position p file-pos)
+                          (resource name
+                                    (read-bytes size p)
+                                    codepage
+                                    file-pos)))))
+                (begin
+                  (file-position p next)
+                  (iloop (add1 i)))))))))))
+
+(define (write-rsrcs rsrcs p virtual-addr)
+  (define (sorted-directory-content e)
+    (sort (directory-content e)
+          #:key entry-name
+          (lambda (a b)
+            (cond
+             [(string? a)
+              (if (string? a)
+                  (string<? a b)
+                  #f)]
+             [(string? b) #f]
+             [else
+              (< a b)]))))
+  ;; Compute offsets ----------------------------------------
+  (define (directory-size e)
+    (+ 16 (* 8 (length (directory-content e)))))
+  (define-values (dir-end-pos rev-entries dir-pos-ht)
+    (let loop ([rsrcs rsrcs]
+               [pos (directory-size rsrcs)]
+               [rev-entries (list rsrcs)]
+               [dir-pos-ht (hasheq)])
+      (cond
+       [(resource? rsrcs) (values pos (cons rsrcs rev-entries) dir-pos-ht)]
+       [else
+        (define content (sorted-directory-content rsrcs))
+        (define-values (new-pos new-rev-entries new-dir-pos-ht)
+          (let dloop ([content content]
+                      [pos pos]
+                      [rev-entries rev-entries]
+                      [dir-pos-ht dir-pos-ht])
+            (cond
+             [(null? content) (values pos rev-entries dir-pos-ht)]
+             [else
+              (define e (car content))
+              (cond
+               [(directory? e)
+                (dloop (cdr content)
+                       (+ pos (directory-size e))
+                       (cons e rev-entries)
+                       (hash-set dir-pos-ht e pos))]
+               [else
+                (dloop (cdr content) pos rev-entries dir-pos-ht)])])))
+        (let dloop ([content content]
+                    [pos new-pos]
+                    [rev-entries new-rev-entries]
+                    [dir-pos-ht new-dir-pos-ht])
+          (cond
+           [(null? content) (values pos rev-entries dir-pos-ht)]
+           [else
+            (define-values (new-pos new-rev-entries new-dir-pos-ht)
+              (loop (car content) pos rev-entries dir-pos-ht))
+            (dloop (cdr content) new-pos new-rev-entries new-dir-pos-ht)]))])))
+  (define entries (reverse rev-entries))
+  (define align-strings? #f)
+  (define (str-size s)
+    (let ([n (+ 2 (* 2 (string-length s)))])
+      (if align-strings?
+          (if (zero? (bitwise-and n 3))
+              n
+              (+ n (- 4 (bitwise-and n 3))))
+          n)))
+  (define str-length
+    (for/sum ([e (in-list entries)])
+      (if (string? (entry-name e))
+          (str-size (entry-name e))
+          0)))
+  (define aligned-str-length
+    (same-alignment 4 str-length))
+  (define res-start dir-end-pos)
+  (define res-length (* 16 (for/sum ([e (in-list entries)])
+                             (if (resource? e) 1 0))))
+  (define str-start (+ res-start res-length))
+  (define data-start (+ str-start aligned-str-length))
+  (define (align-data-size s)
+    (same-alignment 2 s))
+  
+  ;; Write out directory ----------------------------------------
+  (for/fold ([str-pos str-start] [res-pos res-start]) ([e (in-list entries)])
+    (cond
+     [(resource? e) (values str-pos res-pos)]
+     [(directory? e)
+      (define content (sorted-directory-content e))
+      (integer->dword 0 p)
+      (integer->dword (directory-timestamp e) p)
+      (integer->word (directory-major-version e) p)
+      (integer->word (directory-minor-version e) p)
+      (define num-strs (let loop ([cs content])
+                         (cond
+                          [(null? cs) 0]
+                          [(number? (entry-name (car cs))) 0]
+                          [else (+ 1 (loop (cdr cs)))])))
+      (integer->word num-strs p)
+      (integer->word (- (length content) num-strs) p)
+      (for/fold ([str-pos str-pos] [res-pos res-pos]) ([e (in-list content)])
+        (values (cond
+                 [(string? (entry-name e))
+                  (integer->dword (add-flag str-pos) p)
+                  (+ str-pos (str-size (entry-name e)))]
+                 [else
+                  (integer->dword (entry-name e) p)
+                  str-pos])
+                (cond
+                 [(resource? e)
+                  (integer->dword res-pos p)
+                  (+ res-pos 16)]
+                 [else
+                  (integer->dword (add-flag (hash-ref dir-pos-ht e)) p)
+                  res-pos])))]))
+  
+  ;; Write out resource data entries
+  (for/fold ([data-pos data-start]) ([e (in-list entries)])
+    (cond
+     [(resource? e)
+      (define len (align-data-size (bytes-length (resource-content e))))
+      (integer->dword (+ data-pos virtual-addr) p)
+      (integer->dword len p)
+      (integer->dword (resource-codepage e) p)
+      (integer->dword 0 p)
+      (+ data-pos len)]
+     [else
+      data-pos]))
+  
+  ;; Write out strings
+  (for ([e (in-list entries)])
+    (define n (entry-name e))
+    (when (string? n)
+      (integer->word (string-length n) p)
+      (for ([c (in-string n)])
+        (integer->word (char->integer c) p))
+      (when align-strings?
+        (when (even? (string-length n))
+          (integer->word 0 p)))))
+  (write-bytes (make-bytes (- aligned-str-length str-length)) p)
+  
+  ;; Write out resource content
+  (for ([e (in-list entries)])
+    (when (resource? e)
+      (define bstr (resource-content e))
+      (write-bytes bstr p)
+      (define aligned-size (align-data-size (bytes-length bstr)))
+      (write-bytes (make-bytes (- aligned-size (bytes-length bstr))) p)))
+  
+  (void))
+
+
+(define (find-section sections find-name)
+  (let loop ([sections sections])
+    (cond
+     [(null? sections)
+      (error 'find-section "can't find section: ~e" find-name)]
+     [else
+      (define s (car sections))
+      (if (bytes=? find-name (section-name s))
+          s
+          (loop (cdr sections)))])))
+
+(define rsrc-section-name #".rsrc\0\0\0")
+
+(define (read-pe+resources i)
+  (define pe (read-pe i))
+  (define s (find-section (pe-sections pe) rsrc-section-name))
+  
+  (log-pe-rsrc-debug "sections at ~x" (pe-section-start-pos pe))
+  (show-sections (pe-sections pe))
+  (log-pe-rsrc-debug "rsrc at ~x ~x" (pe-rsrc-virtual-addr pe) (pe-rsrc-size pe))
+  
+  (unless (and (= (section-virtual-addr s) (pe-rsrc-virtual-addr pe))
+               (>= (section-virtual-size s) (pe-rsrc-size pe)))
+    (error 'pe-rsrc
+           "sections and resource information do not line up in the typical way"))
+  
+  (define rsrcs (read-rsrcs i (section-file-position s) (section-virtual-addr s)))
+  
+  (show-resources rsrcs)
+  
+  (values pe rsrcs))
+
+(define (same-alignment orig new)
+  (cond
+   [(bitwise-bit-set? orig 1)
+    new]
+   [(bitwise-bit-set? new 1)
+    (same-alignment orig (add1 new))]
+   [else
+    (arithmetic-shift (same-alignment
+                       (arithmetic-shift orig -1)
+                       (arithmetic-shift new -1))
+                      1)]))
+
+(define (update-sections pe new-sections o)
+  (file-position o (pe-section-start-pos pe))
+  (for ([s (in-list new-sections)])
+    (write-bytes (section-name s) o)
+    (integer->dword (section-virtual-size s) o)
+    (integer->dword (section-virtual-addr s) o)
+    (integer->dword (section-file-length s) o)
+    (integer->dword (section-file-position s) o)
+    (integer->dword 0 o)
+    (integer->dword 0 o)
+    (integer->word 0 o)
+    (integer->word 0 o)
+    (integer->dword (section-characteristics s) o)))
+
+(define (update-resources src pe rsrcs)
+  (define o (open-output-bytes))
+  (write-rsrcs rsrcs o (pe-rsrc-virtual-addr pe))
+  (define bstr (get-output-bytes o))
+  (define len (bytes-length bstr))
+
+  (define s (find-section (pe-sections pe) rsrc-section-name))
+  (cond
+   [(len . <= . (section-file-length s))
+    (log-pe-rsrc-debug "new content fits in place of old content")
+    (call-with-output-file
+     src
+     #:exists 'update
+     (lambda (o)
+       (file-position o (section-file-position s))
+       (write-bytes bstr o)
+       (write-bytes (make-bytes (- (section-file-length s) len)) o)
+       
+       (file-position o (pe-rsrc-offset pe))
+       (integer->dword (pe-rsrc-virtual-addr pe) o)
+       (integer->dword len o)))]
+   [else
+    (log-pe-rsrc-debug "moving resources to end")
+    (define new-virtual-addr
+      (same-alignment
+       (section-virtual-addr s)
+       (for/fold ([pos 0]) ([s2 (in-list (pe-sections pe))]
+                            #:unless (eq? s s2))
+         (max pos
+              (+ (section-virtual-addr s2)
+                 (section-virtual-size s2))))))
+
+    (define o (open-output-bytes))
+    (write-rsrcs rsrcs o new-virtual-addr)
+    (define bstr (get-output-bytes o))
+    (define len (bytes-length bstr))
+    
+    (define new-virtual-size len)
+    (define new-file-size (same-alignment (pe-section-alignment pe) len))
+    (define new-position
+      (let ([fs (file-size src)])
+        (cond
+         [(= fs (+ (section-file-position s)
+                   (section-file-length s)))
+          ;; Section was already at end, so overwrite is ok
+          (section-file-position s)]
+         [else
+          (same-alignment (pe-file-alignment pe) fs)])))
+    (log-pe-rsrc-debug "moving to ~x ~x at ~x"
+                       new-virtual-addr
+                       new-virtual-size
+                       new-position)
+    
+    (define new-sections
+      (sort (for/list ([s2 (in-list (pe-sections pe))])
+              (if (eq? s s2)
+                  (section (section-name s)
+                           new-virtual-size new-virtual-addr
+                           new-file-size new-position
+                           (section-characteristics s))
+                  s2))
+            <
+            #:key section-virtual-addr))
+
+    (call-with-output-file
+     src
+     #:exists 'update
+     (lambda (o)
+       (define exe-size (+ new-position new-file-size))
+       
+       (update-sections pe new-sections o)
+       
+       (file-position o new-position)
+       (write-bytes bstr o)
+       (write-bytes (make-bytes (- new-file-size len)) o)
+    
+       (file-position o (pe-rsrc-offset pe))
+       (integer->dword new-virtual-addr o)
+       (integer->dword new-virtual-size o)
+       
+       (file-position o (pe-image-size-pos pe))
+       (integer->dword (+ new-virtual-addr new-file-size) o)
+       
+       (file-truncate o exe-size)))]))
+
+;; ----------------------------------------
+
+(define (get-match dir n)
+  (and dir
+       (for/or ([e (in-list (directory-content dir))])
+         (and (or (not n)
+                  (equal? n (entry-name e)))
+              e))))
+
+(define (set-match dir v
+                   #:name [name (entry-name v)]
+                   #:can-remove? [can-remove? #f])
+  (define new-content
+    (let loop ([c (directory-content dir)])
+      (cond
+       [(null? c) (if v
+                      (list v)
+                      null)]
+       [(or (not name)
+            (equal? (entry-name (car c)) name))
+        (if v
+            (cons v (cdr c))
+            (cdr c))]
+       [else (cons (car c) (loop (cdr c)))])))
+  (if (and can-remove? (null? new-content))
+      #f
+      (struct-copy directory dir
+                   [content new-content])))
+
+(define (resource-ref/path rsrcs type name language)
+  (define t (get-match rsrcs type))
+  (define n (get-match t name))
+  (define r (get-match n language))
+  (values (and t (entry-name t))
+          (and n (entry-name n))
+          (and r (entry-name r))
+          (and r (resource-content r))
+          (and r (resource-file-pos r))))
+
+(define (resource-ref rsrcs type name language)
+  (define-values (t n l v p) (resource-ref/path rsrcs type name language))
+  v)
+
+(define (resource-set rsrcs type name language v)
+  (define (mk name what)
+    (directory (or name
+                   (error 'resource-set
+                          "cannot infer ~a"
+                          what))
+               0 ; timestamp
+               0 ; major-version
+               0 ; minor-version
+               null))
+  (define t (or (get-match rsrcs type) (mk type 'type)))
+  (define n (or (get-match t name) (mk name 'name)))
+  (define l (get-match n language))
+  (set-match rsrcs #:name type
+             (set-match t
+                        #:name name
+                        (set-match n
+                                   #:name language
+                                   (resource (or language
+                                                 (and l (entry-name l))
+                                                 (error 'resource-set
+                                                        "cannot infer language"))
+                                             v
+                                             1252
+                                             0)))))
+
+(define (resource-remove rsrcs type name language)
+  (define t (get-match rsrcs type))
+  (define n (get-match t name))
+  (if (get-match n language)
+      (set-match rsrcs #:name type
+                 (set-match t
+                            #:name name
+                            #:can-remove? #t
+                            (set-match n
+                                       #:name language
+                                       #:can-remove? #t
+                                       #f)))
+      rsrcs))
+
+#;
+(module+ test
+  (define-syntax-rule (check a b ...)
+    (let ([got (call-with-values (lambda () a) list)]
+          [expect (list b ...)])
+      (unless (equal? got expect)
+        (error 'test "failed: ~.s\n  got: ~e" 'a got))))
+  (define (d name l)
+    (directory name 0 0 0 l))
+  (check (resource-ref (d #f null) #f #f #f)
+         #f)
+  (define hi-d (d #f (list (d 1 (list (d "hi" (list (resource 1033 #"ok" 1252 0))))))))
+  (define hi2-d (d #f (list (d 1 (list (d "hi" (list (resource 1033 #"yep" 1252 0))))))))
+  (check (resource-set (d #f null) 1 "hi" 1033 #"ok")
+         hi-d)
+  (check (resource-remove hi-d #f "no-hi" #f)
+         hi-d)
+  (check (resource-remove hi-d #f "hi" #f)
+         (d #f null))
+  (check (resource-set hi-d #f "hi" #f #"yep")
+         hi2-d)
+  (define bye-d (d #f (list (d 1 (list (d "hi" (list (resource 1033 #"ok" 1252 0)))
+                                       (d "bye" (list (resource 1033 #"ok" 1252 0))))))))
+  (check (resource-set hi-d 1 "bye" 1033 #"ok")
+         bye-d)
+  (check (resource-remove bye-d 1 "bye" #f)
+         hi-d))
+
diff --git a/racket/collects/file/ico.rkt b/racket/collects/file/ico.rkt
index cb7658ccb8..9bc7662227 100644
--- a/racket/collects/file/ico.rkt
+++ b/racket/collects/file/ico.rkt
@@ -1,11 +1,13 @@
 #lang racket/base
-(require racket/contract)
+(require racket/contract
+         compiler/private/pe-rsrc)
 
 (provide ico?
          (contract-out
-          [ico-width (ico? . -> . (integer-in 1 256))]
-          [ico-height (ico? . -> . (integer-in 1 256))]
-          [ico-depth (ico? . -> . (one-of/c 1 2 4 8 16 24 32))]
+          [ico-width (ico? . -> . exact-positive-integer?)]
+          [ico-height (ico? . -> . exact-positive-integer?)]
+          [ico-depth (ico? . -> . (or/c 1 2 4 8 16 24 32))]
+          [ico-format (ico? . -> . (or/c 'bmp 'png))]
           
           [read-icos ((or/c path-string? input-port?) . -> . (listof ico?))]
           [read-icos-from-exe ((or/c path-string? input-port?) . -> . (listof ico?))]
@@ -16,14 +18,19 @@
                                        'must-truncate 'truncate/replace)]
                        . ->* .
                        void?)]
-          [replace-icos ((listof ico?) (or/c path-string? output-port?)
-                         . -> . void?)]
+          [replace-icos ((listof ico?) path-string? . -> . void?)]
+          [replace-all-icos ((listof ico?) path-string? . -> . void?)]
           
           [ico->argb (ico? . -> . bytes?)]
+          [ico->png-bytes (ico? . -> . bytes?)]
           [argb->ico ([(integer-in 1 256) (integer-in 1 256) bytes? ]
                       [#:depth (one-of/c 1 2 4 8 24 32)]
                       . ->* . 
-                      ico?)]))
+                      ico?)]
+          [png-bytes->ico ([bytes?]
+                           []
+                           . ->* . 
+                           ico?)]))
 
 ;; parse-ico build-ico
 
@@ -46,107 +53,21 @@
 (define (integer->3/2word i p)
   (display (subbytes (integer->integer-bytes i 4 #f #f) 0 3) p))
 
-(define (flag v)
-  (positive? (bitwise-and #x80000000 v)))
-(define (value v)
-  (bitwise-and #x7FFFFFFF v))
-
-(define (skip-to-image-headers-after-signature p)
-  ;; p is expected to be a file port
-  (file-position p 60)
-  (let ([pos (word->integer p)])
-    ;; pos points to IMAGE_NT_HEADERS
-    (file-position p pos)
-    (unless (= #x4550 (dword->integer p))
-      (error "bad signature"))
-    pos))
-
-(define (get-image-base p)
-  (let ([pos (skip-to-image-headers-after-signature p)])
-    (file-position p (+ 4
-                        20
-                        28))
-    (dword->integer p)))
-
-(define (find-section p find-name)
-  (let ([pos (skip-to-image-headers-after-signature p)])
-    (word->integer p) ; skip machine
-    (let ([num-sections (word->integer p)]
-          [_ (begin (dword->integer p)
-                    (dword->integer p)
-                    (dword->integer p))]
-          [size (word->integer p)])
-      (let ([pos (+ pos
-                    4       ; Signature : DWORD
-                    20      ; FileHeader: IMAGE_FILE_HEADER
-                    size)]) ; "optional" header
-        (let sloop ([section 0][section-pos pos])
-          (if (= section num-sections)
-              (error 'find-section "can't find section: ~e" find-name)
-              (begin
-                (file-position p section-pos)
-                ;; p points to an IMAGE_SECTION_HEADER
-                (let ([name (read-bytes 8 p)])
-                  (if (bytes=? find-name name)
-                      (let ([_ (dword->integer p)]) ; skip
-                        (values (dword->integer p)  ; virtual address
-                                (dword->integer p)  ; length
-                                (dword->integer p))); file pos
-                      (sloop (add1 section) (+ section-pos 40)))))))))))
-
-(define (find-rsrc-start p re:rsrc)
-  (let-values ([(rsrc-virtual-addr rsrc-len rsrc-pos)
-                (find-section p #".rsrc\0\0\0")])
-    (let loop ([dir-pos 0][path ""])
-      (file-position p (+ rsrc-pos dir-pos 12))
-      (let ([num-named (word->integer p)]
-            [num-ided (word->integer p)])
-        (let iloop ([i 0])
-          (if (= i (+ num-ided num-named))
-              #f
-              (let ([name-delta (dword->integer p)]
-                    [data-delta (dword->integer p)]
-                    [next (file-position p)])
-                (or (let ([name (if (flag name-delta)
-                                    (begin
-                                      (file-position p (+ rsrc-pos (value name-delta)))
-                                      (let* ([len (word->integer p)])
-                                        ;; len is in unicode chars...
-                                        (let ([unistr (read-bytes (* 2 len) p)])
-                                          ;; Assume it fits into ASCII...
-                                          (regexp-replace* "\0" 
-                                                           (bytes->string/latin-1 unistr)
-                                                           ""))))
-                                    (value name-delta))])
-                      ;;(printf "Name: ~a~a = ~a\n" path name (+ rsrc-pos (value data-delta)))
-                      (let ([full-name (format "~a~a" path name)])
-                        (if (flag data-delta)
-                            (loop (value data-delta) (string-append full-name "."))
-                            ;; Found the icon?
-                            (and (regexp-match re:rsrc full-name)
-                                 ;; Yes, so read IMAGE_RESOURCE_DATA_ENTRY
-                                 (begin
-                                   (file-position p (+ rsrc-pos (value data-delta)))
-                                   (cons
-                                    (+ (dword->integer p)           ; offset (an RVA)
-                                       (- rsrc-pos
-                                          rsrc-virtual-addr))
-                                    (dword->integer p)))))))        ; size
-                    (begin
-                      (file-position p next)
-                      (iloop (add1 i)))))))))))
-
 (define-struct ico (desc data) #:mutable)
 ;; desc is (list width height colors 0 planes bitcount)
 ;; data is (cons pos bytes)
 
 (define (ico-width i) (let ([v (car (ico-desc i))])
                         (if (= v 0)
-                            256
+                            (if (eq? (ico-format i) 'bmp)
+                                256
+                                (ico-png-width i))
                             v)))
 (define (ico-height i) (let ([v (cadr (ico-desc i))])
                          (if (= v 0)
-                             256
+                             (if (eq? (ico-format i) 'bmp)
+                                 256
+                                (ico-png-height i))
                              v)))
 (define (ico-depth i) 
   (let ([cols (caddr (ico-desc i))])
@@ -155,6 +76,26 @@
         (integer-length (sub1 cols)))))
 (define (ico-colors i) (num-colors (ico-desc i)))
 
+(define (ico-format i)
+  (define bstr (cdr (ico-data i)))
+  (define tag (subbytes bstr 0 2))
+  (cond
+   [(and ((bytes-length bstr) . > . 4)
+         (equal? (subbytes bstr 0 4) #"\211PNG"))
+    'png]
+   [else
+    ;; Asume BMP
+    'bmp]))
+
+(define (ico-png-width i)
+  (png-width (cdr (ico-data i))))
+(define (png-width bstr)
+  (integer-bytes->integer (subbytes bstr 16 20) #f #t))
+(define (ico-png-height i)
+  (png-height (cdr (ico-data i))))
+(define (png-height bstr)
+  (integer-bytes->integer (subbytes bstr 20 24) #f #t))
+
 (define (num-colors l)
   (let ([n (caddr l)])
     (if (zero? n)
@@ -173,8 +114,8 @@
                             (ormap (lambda (ico-ico)
                                      (let ([le (ico-desc exe-ico)]
                                            [li (ico-desc ico-ico)])
-                                       (and (= (car li) (car le))
-                                            (= (cadr li) (cadr le))
+                                       (and (= (ico-width exe-ico) (ico-width ico-ico))
+                                            (= (ico-height exe-ico) (ico-height ico-ico))
                                             (= (num-colors li) (num-colors le))
                                             (= (bytes-length (cdr (ico-data exe-ico)))
                                                (bytes-length (cdr (ico-data ico-ico))))
@@ -185,8 +126,8 @@
                                           ;; need a 16x16, 32x32, or 48x48
                                           ;; ico
                                           (and
-                                           (= (car (ico-desc exe-ico))
-                                              (cadr (ico-desc exe-ico)))
+                                           (= (ico-width exe-ico)
+                                              (ico-height exe-ico))
                                            (memq (car (ico-desc exe-ico))
                                                  '(16 32 48))
                                            (let ([biggest-colorest #f])
@@ -249,16 +190,88 @@
                                                                    #t)))))))))])
                          (unless ico-ico (log-error "no icon conversion available to ~a" (ico-desc exe-ico)))
                          (when ico-ico
-                           (file-position p (car (ico-data exe-ico)))
+                           (file-position p (let ([d (car (ico-data exe-ico))])
+                                              (if (vector? d)
+                                                  (vector-ref d 0)
+                                                  d)))
                            (display (cdr (ico-data ico-ico)) p)))))
                    exe-icos))
        (lambda () (close-output-port p))))))
 
+(define (replace-all-icos ico-list exe-file)
+  (define-values (pe rsrcs)
+    (call-with-input-file*
+     exe-file
+     read-pe+resources))
+  (define-values (type name language icos file-pos)
+    (resource-ref/path rsrcs 14 #f #f))
+  (define old-icos
+    (if icos
+        (get-icos (open-input-bytes icos) rsrcs)
+        null))
+  (define (ico-res-type i) (vector-ref (car (ico-data i)) 1))
+  (define (ico-res-name i) (vector-ref (car (ico-data i)) 2))
+  (define (ico-res-language i) (vector-ref (car (ico-data i)) 3))
+  (define cleaned-rsrcs
+    (for/fold ([rsrcs rsrcs]) ([old-i (in-list old-icos)])
+      (resource-remove rsrcs
+                       (ico-res-type old-i)
+                       (ico-res-name old-i)
+                       (ico-res-language old-i))))
+  ;; Replace individual icons where size and depth match
+  (define-values (new-rsrcs named-icos)
+    (for/fold ([rsrcs cleaned-rsrcs] [named-icos null]) ([i (in-list ico-list)])
+      (define old-i (for/or ([old-i (in-list old-icos)])
+                      (and (= (ico-width i) (ico-width old-i))
+                           (= (ico-height i) (ico-height old-i))
+                           (= (ico-depth i) (ico-depth old-i))
+                           old-i)))
+      (define name
+        (cond
+         [old-i (ico-res-name old-i)]
+         [else
+          ;; Generate next unused id:
+          (let loop ([id 1])
+            (if (resource-ref rsrcs 3 id 1033)
+                (loop (add1 id))
+                id))]))
+      (values (resource-set rsrcs
+                            3
+                            name
+                            1033
+                            (cdr (ico-data i)))
+              (cons (ico (ico-desc i)
+                         (cons (vector #f 4 name 1033)
+                               (cdr (ico-data i))))
+                    named-icos))))
+  ;; Update ico:
+  (define ready-rsrcs
+    (resource-set new-rsrcs type name language (make-icos-header named-icos)))
+  ;; Write new resources:
+  (update-resources exe-file pe ready-rsrcs))
+
+(define (make-icos-header icos)
+  (define o (open-output-bytes))
+  (integer->word 0 o)
+  (integer->word 1 o)
+  (integer->word (length icos) o)
+  (for ([i (in-list icos)])
+    (define desc (ico-desc i))
+    (write-byte (list-ref desc 0) o)
+    (write-byte (list-ref desc 1) o)
+    (write-byte (list-ref desc 2) o)
+    (write-byte (list-ref desc 3) o)
+    (integer->word (list-ref desc 4) o)
+    (integer->word (list-ref desc 5) o)
+    (integer->dword (bytes-length (cdr (ico-data i))) o)
+    (integer->word (vector-ref (car (ico-data i)) 2) o))
+  (get-output-bytes o))
+
 ;; ------------------------------
 ;;  Image parsing
 ;; ------------------------------
 
-(define (get-icos file res?)
+(define (get-icos file rsrcs)
   (let ([p (if (input-port? file)
                file
                (open-input-file file))])
@@ -282,7 +295,7 @@
                                    (word->integer p)   ; planes
                                    (word->integer p))  ; bitcount
                              (list (dword->integer p)  ; bytes
-                                   ((if res?           ; where or icon id
+                                   ((if rsrcs          ; where or icon id
                                         word->integer 
                                         dword->integer)
                                     p)))
@@ -293,14 +306,16 @@
                         ico
                         (let ([size (car (ico-data ico))]
                               [where (cadr (ico-data ico))])
-                          (let ([ico-pos (if res?
-                                             ;; last number is icon id:
-                                             (car (find-rsrc-start p (regexp (format "^3[.]~a[.]" where))))
-                                             ;; last number is file position:
-                                             where)])
-                            (file-position p ico-pos)
-                            (cons ico-pos
-                                  (read-bytes size p)))))
+                          (cond
+                           [rsrcs
+                            (define-values (type name lang bstr file-pos)
+                              (resource-ref/path rsrcs 3 where #f))
+                            (cons (vector file-pos type name lang)
+                                  bstr)]
+                           [else
+                            (file-position p where)
+                            (cons where
+                                  (read-bytes size p))])))
                        ;; If colors, planes, and bitcount are all 0,
                        ;;  get the info from the DIB data
                        (let ([desc (ico-desc ico)])
@@ -595,6 +610,8 @@
           (cadr image)))) ; list of mask pixels
 
 (define (ico->argb ico)
+  (unless (eq? 'bmp (ico-format ico))
+    (error 'ico->argb "icon not in BMP format"))
   (let* ([image (parse-ico ico)]
          [pixels (list-ref image 3)]
          [len (length pixels)]
@@ -616,6 +633,11 @@
         (bytes-set! bstr (+ 3 (* i 4)) (bitwise-and #xff p))))
     bstr))
 
+(define (ico->png-bytes ico)
+  (unless (eq? 'png (ico-format ico))
+    (error 'ico->argb "icon not in PNG format"))
+  (cdr (ico-data ico)))
+
 (define (build-ico base-ico image mask check?)
   (make-ico (ico-desc base-ico)
             (cons (car (ico-data base-ico))
@@ -625,14 +647,12 @@
   (get-icos ico-file #f))
 
 (define (read-icos-from-exe exe-file)
-  (let ([p (open-input-file exe-file)])
-    (dynamic-wind
-     void
-     (lambda ()
-       (let ([pos+size (find-rsrc-start p #rx"^14[.]")])
-         (file-position p (car pos+size))
-         (get-icos p #t)))
-     (lambda () (close-input-port p)))))
+  (define-values (pe rsrcs)
+    (call-with-input-file*
+     exe-file
+     read-pe+resources))
+  (define icos (resource-ref rsrcs 14 #f #f))
+  (get-icos (open-input-bytes icos) rsrcs))
 
 (define (write-header w h depth o)
   (integer->dword 40 o) ; size
@@ -647,6 +667,11 @@
   (integer->dword 0 o)  ; used
   (integer->dword 0 o))  ; important
 
+(define (png-bytes->ico bstr)
+  (define (256+->0 v) (if (v . >= . 256) 0 v))
+  (ico (list (256+->0 (png-width bstr)) (256+->0 (png-height bstr)) 0 0 1 32)
+       (cons #f bstr)))
+
 (define (argb->ico w h argb #:depth [depth 32])
   (let ([o (open-output-bytes)])
     (write-header w h 32 o)